写了个拉丁转俄文字母的程序

By xaengceilbiths at 2019-05-05 • 0人收藏 • 123人看过

;; 标准是某GOST但用w代替shh

;; w = shh

(define lat '("a" "b" "v" "g" "d" "e" "jo" "zh" "z" "i" "j" "k" "l" "m" "n" "o" "p" "r" "s" "t" "u" "f" "kh" "c" "ch" "sh" "w" "\"" "y" "'" "eh" "ju" "ja"))

;; cyrillic

(define cyr '("а" "б" "в" "г" "д" "е" "ё" "ж" "з" "и" "й" "к" "л" "м" "н" "о" "п" "р" "с" "т" "у" "ф" "х" "ц" "ч" "ш" "щ" "ъ" "ы" "ь" "э" "ю" "я"))

;; unused

(define cyr-up '("А" "Б" "В" "Г" "Д" "Е" "Ё" "Ж" "З" "И" "Й" "К" "Л" "М" "Н" "О" "П" "Р" "С" "Т" "У" "Ф" "Х" "Ц" "Ч" "Ш" "Щ" "Ъ" "Ы" "Ь" "Э" "Ю" "Я"))


;; In scheme string-upcase considers UNICODE including cyrillic char

;; 本程序中只要原文任意拉丁字母为大写则西里尔字母为大写

(define (recase str recase?)

  (if recase? (string-upcase str) str))


;; This function keeps irrelevant chars like #\space


(define (convert-complex str)

  (define sln (string-length str))

  (define al-big (map cons lat cyr))

  (define al2 (filter (lambda (c) (= 2 (string-length (car c)))) al-big))

  (define al0.5 (filter (lambda (c) (= 1 (string-length (car c)))) al-big))

  ;; 其实字符太少,没必要remove-dup

  (define (remove-dup cl)

    (define (cmp c1 c2)

      (< (char->integer c1) (char->integer c2)))

    (define (f l)

      (cond

       [(null? l) '()]

       [(null? (cdr l)) l]

       [(eq? (car l) (cadr l))

        (f (cons (car l) (cddr l)))]

       [else (cons (car l) (f (cdr l)))]))

    (let ((scl (sort cmp cl)))

      (f scl)))

  (define pre (remove-dup (map (lambda (str) (string-ref str 0)) (map car al2))))

  (define al1 (filter (lambda (c) (memq (string-ref (car c) 0) pre)) al0.5))

  (define al0 (filter (lambda (c) (not (memq (string-ref (car c) 0) pre))) al0.5))

  (define (find-res reg al)

    (let* ([S0 (list->string (reverse reg))]

           [s0 (string-downcase S0)]

           [recase? (not (string=? s0 S0))]

           [s1 (assp (lambda (s) (string=? s s0)) al)])

      (and s1 (recase (cdr s1) recase?))))

  (let loop ((i 0) (reg '()) (res '()))

    (if (< i sln)

        (let ([reg (cons (string-ref str i) reg)])

          (cond

           [(and (= 2 (length reg))

                 (find-res reg al2)) =>

                 (lambda (r)

                   (loop (+ i 1) '() (cons r res)))]

           ;; 需要继续处理,留在原地,并重置寄存器

           [(and (= 2 (length reg))

                 (find-res (cdr reg) al1)) =>

                 (lambda (r)

                   (loop i '() (cons r res)))]

           [(and (= 1 (length reg))

                 (find-res reg al0)) =>

                 (lambda (r)

                   (loop (+ i 1) '() (cons r res)))]

           [(and (= 1 (length reg))

                 (find-res reg al1))

            (loop (+ i 1) reg res)]

           ;; (list->string '()) == ""

           [else

            (loop (+ i 1) '() (cons (list->string (reverse reg)) res))]))

      (if (> i sln)

          (apply string-append (reverse res))

        ;; (length reg) == 0 或 1

        (cond

         [(null? reg)

          (loop (+ i 1) '() res)]

         [(find-res reg al0) =>

          (lambda (r)

            (loop (+ i 1) '() (cons r res)))]

         [(find-res reg al1) =>

          (lambda (r)

            (loop (+ i 1) '() (cons r res)))]

         [else

          (loop (+ i 1) '() (cons (list->string reg) res))])))))


1 个回复 | 最后更新于 2019-05-06
2019-05-06   #1

登录后方可回帖

登 录
信息栏

Scheme中文社区

推荐实现 ChezScheme / r6rs / r7rs large
theschemer.org
Q群: 724577239

精华导览

社区项目

包管理器:Raven
HTTP服务器:Igropyr (希腊火)
官方插件:vscode-chez

社区目标:

完善足以使Scheme工程化和商业化的库,特别是开发极致速度的Web服务器和ANN模块。

一直以来Scheme缺少一个活跃的中文社区,同时中文资料的稀少,导致大多数因为黑客与画家和SICP而接触Scheme的朋友,在学完SICP后无事可做,不能将Scheme转换为实际的生产力。最后渐渐的放弃。
同时Chicken等实现,却因效率问题无法与其他语言竞争。本社区只有一个目的,传播Scheme的文明之火,在最快的编译器实现上,集众人之力发展出足够与其他语言竞争的社区和库。


友情链接:

Clojure 中文论坛
函数式·China


Loading...