home *** CD-ROM | disk | FTP | other *** search
/ Clickx 115 / Clickx 115.iso / software / tools / windows / tails-i386-0.16.iso / live / filesystem.squashfs / usr / share / uim / rk.scm < prev    next >
Encoding:
Text File  |  2010-11-07  |  9.0 KB  |  332 lines

  1. ;;;
  2. ;;; Copyright (c) 2003-2009 uim Project http://code.google.com/p/uim/
  3. ;;;
  4. ;;; All rights reserved.
  5. ;;;
  6. ;;; Redistribution and use in source and binary forms, with or without
  7. ;;; modification, are permitted provided that the following conditions
  8. ;;; are met:
  9. ;;; 1. Redistributions of source code must retain the above copyright
  10. ;;;    notice, this list of conditions and the following disclaimer.
  11. ;;; 2. Redistributions in binary form must reproduce the above copyright
  12. ;;;    notice, this list of conditions and the following disclaimer in the
  13. ;;;    documentation and/or other materials provided with the distribution.
  14. ;;; 3. Neither the name of authors nor the names of its contributors
  15. ;;;    may be used to endorse or promote products derived from this software
  16. ;;;    without specific prior written permission.
  17. ;;;
  18. ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS IS'' AND
  19. ;;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
  20. ;;; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
  21. ;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE
  22. ;;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
  23. ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
  24. ;;; OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
  25. ;;; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
  26. ;;; LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
  27. ;;; OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
  28. ;;; SUCH DAMAGE.
  29. ;;;;
  30.  
  31. ;;
  32. ; following functions are implemented within C
  33. ;  rk-lib-find-seq
  34. ;  rk-lib-find-partial-seq
  35. ;  rk-lib-expect-seq
  36. ;
  37. ; back match is mainly used for Hangul
  38.  
  39. (define-record 'rk-context
  40.   '((rule             ())
  41.     (seq              ())
  42.     (immediate-commit #f)
  43.     (back-match       #f)))
  44. (define rk-context-new-internal rk-context-new)
  45.  
  46. (define rk-context-new
  47.   (lambda (rule immediate-commit back)
  48.     (rk-context-new-internal rule () immediate-commit back)))
  49.  
  50. ;; back match
  51. (define rk-find-longest-back-match
  52.   (lambda (rule seq)
  53.     (if (not (null? seq))
  54.     (if (rk-lib-find-seq seq rule)
  55.         seq
  56.         (rk-find-longest-back-match rule (cdr seq)))
  57.     '())))
  58. ;; back match
  59. (define rk-find-longest-head
  60.   (lambda (rseq rule)
  61.     (let ((seq (reverse rseq)))
  62.       (if (rk-lib-find-seq seq rule)
  63.       seq
  64.       (if (not (null? rseq))
  65.           (rk-find-longest-head (cdr rseq) rule)
  66.           '())))))
  67. ;; back match
  68. (define rk-check-back-commit
  69.   (lambda (rkc rule rseq)
  70.     (let* ((seq (reverse rseq))
  71.        (len (length seq))
  72.        (longest-tail (rk-find-longest-back-match rule seq))
  73.        (longest-head (reverse (rk-find-longest-head rseq rule)))
  74.        (head
  75.         (truncate-list seq
  76.                (- len (length longest-tail))))
  77.        (partial (rk-lib-find-partial-seq seq rule))
  78.        (tail-partial
  79.         (if (not (null? longest-tail))
  80.         (rk-lib-find-partial-seq longest-tail rule)
  81.         #f))
  82.        (c (rk-lib-find-seq longest-tail rule))
  83.        (t (rk-lib-find-seq seq rule))
  84.        (res #f))
  85.       (and
  86.        (if (> len 0)
  87.        #t
  88.        #f)
  89.        (if partial
  90.        #f
  91.        #t)
  92.        (if (and c t)
  93.        #f
  94.        #t)
  95.        (if (not tail-partial)
  96.        (let ((matched (rk-lib-find-seq (reverse longest-head) rule))
  97.          (tail (reverse (truncate-list (reverse seq)
  98.                            (- len
  99.                           (length longest-head))))))
  100.          (if matched
  101.          (set! res (cadr matched)))
  102.          (if (and
  103.           res
  104.           (or
  105.            (not (null? longest-tail))
  106.            (rk-lib-find-partial-seq tail rule)))
  107.          (rk-context-set-seq! rkc tail)
  108.          (rk-context-set-seq! rkc '())) ;; no match in rule
  109.          #f)
  110.        #t)
  111.        (let ((matched (rk-lib-find-seq head rule)))
  112.      (if matched
  113.          (set! res (cadr matched)))
  114.      (rk-context-set-seq! rkc (reverse longest-tail))))
  115.       res)))
  116. ;;
  117. (define rk-partial-seq?
  118.   (lambda (rkc s)
  119.     (if (null? s)
  120.         #f
  121.         (rk-lib-find-partial-seq (reverse s) (rk-context-rule rkc)))))
  122.  
  123. ;; API
  124. (define rk-partial?
  125.   (lambda (rkc)
  126.     (if (rk-context-back-match rkc)
  127.     (if (not (null? (rk-context-seq rkc)))
  128.         #t
  129.         #f)
  130.     (rk-partial-seq?
  131.      rkc
  132.      (rk-context-seq rkc)))))
  133.  
  134. ;; API
  135. (define rk-current-seq
  136.   (lambda (rkc)
  137.     (let* ((s (rk-context-seq rkc))
  138.        (rule (rk-context-rule rkc)))
  139.       (rk-lib-find-seq (reverse s) rule))))
  140.  
  141. ;; API
  142. (define rk-flush
  143.   (lambda (context)
  144.     (rk-context-set-seq! context ())))
  145.  
  146. ;; API
  147. (define rk-backspace
  148.   (lambda (context)
  149.     (if
  150.      (pair? (rk-context-seq context))
  151.      (begin
  152.        (rk-context-set-seq! context
  153.          (cdr (rk-context-seq context)))
  154.        ;; If the sequence contains only non-representable keysyms after
  155.        ;; the deletion, flush them.
  156.        (if (and
  157.         (pair? (rk-context-seq context))
  158.         (null? (remove
  159.             (lambda (x)
  160.              (and
  161.               (intern-key-symbol x)
  162.               (not (symbol-bound? (string->symbol x)))))
  163.             (rk-context-seq context))))
  164.        (rk-flush context))
  165.        #t)
  166.      #f)))
  167.  
  168. ;; API
  169. (define rk-delete
  170.   (lambda (context)
  171.     (if
  172.      (pair? (rk-context-seq context))
  173.      (begin
  174.        (rk-context-set-seq! context
  175.          (cdr (rk-context-seq context)))
  176.        ;; If the sequence contains only non-representable keysyms after
  177.        ;; the deletion, flush them.
  178.        (if (and
  179.         (not (null? (rk-context-seq context)))
  180.         (null? (remove
  181.             (lambda (x)
  182.              (and
  183.               (intern-key-symbol x)
  184.               (not (symbol-bound? (string->symbol x)))))
  185.             (rk-context-seq context))))
  186.        (rk-flush context))
  187.  
  188.        #t)
  189.      #f)))
  190.  
  191.  
  192. ; Merges two strings that have been converted, for example
  193. ; ("ñ≤" "Ñ≤" "íí") ("1" "1" "1") --> ("ñ≤1" "Ñ≤1" "íí1").
  194. ; SEQ1 and SEQ2 must be proper lists having the same length.
  195. ; A disgusting hack for implementing ("n" "1") --> ("ñ≤1").
  196. ; Anyone with the time, skill and passion, please clean this up :-(
  197. (define rk-merge-seqs
  198.   (lambda (seq1 seq2)
  199.     (if (and (pair? seq1) (pair? seq2))
  200.     (cons (string-append (car seq1) (car seq2))
  201.           (rk-merge-seqs (cdr seq1) (cdr seq2)))
  202.     ; This should be () when we reach the end of the lists, or
  203.     ; whatever passed as SEQ1 if SEQ2 is #f
  204.     seq1)))
  205.  
  206. ;; front match
  207. (define rk-proc-tail
  208.   (lambda (context seq)
  209.     (let* ((rule (rk-context-rule context))
  210.        (old-seq
  211.         (rk-lib-find-seq
  212.          (reverse (rk-context-seq context)) rule))
  213.        (res #f))
  214.       (if old-seq
  215.       (begin
  216.         (rk-flush context)
  217.         ;; Comment out the code using rk-merge-seqs for the
  218.         ;; moment because of rk-backspace problem -- ekato
  219.         ;;(set! res
  220.         ;;      (rk-merge-seqs
  221.         ;;       (cadr old-seq)
  222.         ;;       (rk-push-key! context (car seq)))))
  223.         ;;
  224.         (rk-push-key! context (car seq))
  225.         (set! res (cadr old-seq)))
  226.         ;;
  227.       (if (not (null? (rk-context-seq context)))
  228.           (begin
  229.         (rk-flush context)
  230.         (set! res
  231.               (rk-push-key! context (car seq))))))
  232.       res)))
  233.  
  234.  
  235. (define rk-proc-end-seq
  236.   (lambda (context seq s)
  237.     (if (rk-context-immediate-commit context)
  238.     (if seq
  239.         (let ((latter (cadr seq)))
  240.           (rk-context-set-seq! context (cdar seq))
  241.           (if (not (null? latter))
  242.           latter
  243.           #f))
  244.         (begin
  245.           (rk-context-set-seq! context '())
  246.           #f))
  247.     (begin
  248.       (rk-context-set-seq! context s)
  249.       #f))))
  250. ;; API
  251. (define rk-expect
  252.   (lambda (rkc)
  253.     (let
  254.     ((s (reverse (rk-context-seq rkc)))
  255.      (rule (rk-context-rule rkc)))
  256.       (rk-lib-expect-seq s rule))))
  257.  
  258. ;; back match
  259. (define rk-push-key-back-match
  260.   (lambda (rkc key)
  261.     (let*
  262.     ((cur-seq (rk-context-seq rkc))
  263.      (new-seq (cons key cur-seq))
  264.      (rule (rk-context-rule rkc)))
  265.       (rk-context-set-seq! rkc new-seq)
  266.       (rk-check-back-commit rkc rule new-seq))))
  267.  
  268. ;; front match
  269. (define rk-push-key-front-match
  270.   (lambda (rkc key)
  271.     (let*
  272.     ((s (rk-context-seq rkc))
  273.      (s (cons key s))
  274.      (rule (rk-context-rule rkc))
  275.      (seq (rk-lib-find-seq (reverse s) rule))
  276.      (res #f))
  277.       (set!
  278.        res
  279.        (if (rk-partial-seq? rkc s)
  280.        (begin
  281.          (rk-context-set-seq! rkc s)
  282.          #f)
  283.        (if seq
  284.            (rk-proc-end-seq rkc seq s)
  285.            (rk-proc-tail rkc s))))
  286.       res)))
  287.  
  288. ;; API
  289. ;; returns the rule entry that exactly matches with current pending
  290. ;; key sequence. rkc will not be altered.
  291. (define rk-peek-terminal-match
  292.   (lambda (rkc)
  293.     (let ((rule-entry (rk-current-seq rkc)))
  294.       (and rule-entry
  295.        (cadr rule-entry)))))
  296.  
  297. ;; API
  298. ;;─╢┼¼┼÷íúrk.scmñ≥═²▓≥ñ╣ñδñ½íóñóñ╚ñ╟ñ┤ñ├ñ╜ñΩ└▀╖╫ñ╖ñ╩ñ¬ñ╣╗÷íú
  299. ;;
  300. ;; The procedure name is confusable. I suggest rk-terminate-input!
  301. ;;  -- YamaKen 2004-10-25
  302. (define rk-push-key-last!
  303.   (lambda (rkc)
  304.     (let*
  305.     ((s (rk-context-seq rkc))
  306.      (rule (rk-context-rule rkc))
  307.      (seq (rk-lib-find-seq (reverse s) rule)))
  308.       (rk-proc-end-seq rkc seq s)
  309.       )))
  310.  
  311. ;; API
  312. ;; returns string list or #f
  313. (define rk-push-key!
  314.   (lambda (rkc key)
  315.     (if (rk-context-back-match rkc)
  316.     ;; mainly for Hangul
  317.     (rk-push-key-back-match rkc key)
  318.     ;; for other languages
  319.     (rk-push-key-front-match rkc key))))
  320. ;; API
  321. (define rk-pending
  322.   (lambda (c)
  323.     (string-list-concat
  324.      ;; remove keysyms not representable in IM
  325.      (filter-map
  326.       (lambda (x) (if (intern-key-symbol x)
  327.               (if (symbol-bound? (string->symbol x))
  328.                   (symbol-value (string->symbol x))
  329.               "")
  330.               x))
  331.       (rk-context-seq c)))))
  332.