home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / pcscheme / geneva / sources.exe / SOURCES / EDWIN / INCSER.S < prev    next >
Encoding:
Text File  |  1993-06-15  |  11.9 KB  |  323 lines
  1. ;;;
  2. ;;;    Copyright (c) 1985 Massachusetts Institute of Technology
  3. ;;;
  4. ;;;    This material was developed by the Scheme project at the
  5. ;;;    Massachusetts Institute of Technology, Department of
  6. ;;;    Electrical Engineering and Computer Science.  Permission to
  7. ;;;    copy this software, to redistribute it, and to use it for any
  8. ;;;    purpose is granted, subject to the following restrictions and
  9. ;;;    understandings.
  10. ;;;
  11. ;;;    1. Any copy made of this software must include this copyright
  12. ;;;    notice in full.
  13. ;;;
  14. ;;;    2. Users of this software agree to make their best efforts (a)
  15. ;;;    to return to the MIT Scheme project any improvements or
  16. ;;;    extensions that they make, so that these may be included in
  17. ;;;    future releases; and (b) to inform MIT of noteworthy uses of
  18. ;;;    this software.
  19. ;;;
  20. ;;;    3.  All materials developed as a consequence of the use of
  21. ;;;    this software shall duly acknowledge such use, in accordance
  22. ;;;    with the usual standards of acknowledging credit in academic
  23. ;;;    research.
  24. ;;;
  25. ;;;    4. MIT has made no warrantee or representation that the
  26. ;;;    operation of this software will be error-free, and MIT is
  27. ;;;    under no obligation to provide any services, by way of
  28. ;;;    maintenance, update, or otherwise.
  29. ;;;
  30. ;;;    5.  In conjunction with products arising from the use of this
  31. ;;;    material, there shall be no use of the name of the
  32. ;;;    Massachusetts Institute of Technology nor of any adaptation
  33. ;;;    thereof in any advertising, promotional, or sales literature
  34. ;;;    without prior written consent from MIT in each case.
  35. ;;;
  36. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  37. ;;;
  38. ;;;     Modified by Texas Instruments Inc 8/15/85
  39. ;;;
  40. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  41.  
  42.  
  43. ;;;; Incremental Search
  44.  
  45. ;;;; Search State Abstraction
  46.  
  47. (define search-state-tag "Search State")
  48.  
  49. (define (make-search-state text parent forward? successful?
  50.                start-point end-point point initial-point)
  51.   (let ((state (make-vector 9)))
  52.     (vector-set! state 0 search-state-tag)
  53.     (vector-set! state 1 text)
  54.     (vector-set! state 2 parent)
  55.     (vector-set! state 3 forward?)
  56.     (vector-set! state 4 successful?)
  57.     (vector-set! state 5 start-point)
  58.     (vector-set! state 6 end-point)
  59.     (vector-set! state 7 point)
  60.     (vector-set! state 8 initial-point)))
  61.  
  62. (begin
  63. (define-integrable search-state-index:text         1)
  64. (define-integrable search-state-index:parent       2)
  65. (define-integrable search-state-index:forward?     3)
  66. (define-integrable search-state-index:successful?  4)
  67. (define-integrable search-state-index:start-point  5)
  68. (define-integrable search-state-index:end-point    6)
  69. (define-integrable search-state-index:point        7)
  70. (define-integrable search-state-index:initial-point 8)
  71.  
  72. (define-integrable search-state-text
  73.   (lambda (search-state)
  74.     (vector-ref search-state search-state-index:text)))
  75.  
  76. (define-integrable search-state-parent
  77.   (lambda (search-state)
  78.     (vector-ref search-state search-state-index:parent)))
  79.  
  80. (define-integrable search-state-forward?
  81.   (lambda (search-state)
  82.     (vector-ref search-state search-state-index:forward?)))
  83.  
  84. (define-integrable search-state-start-point
  85.   (lambda (search-state)
  86.     (vector-ref search-state search-state-index:start-point)))
  87.  
  88. (define-integrable search-state-end-point
  89.   (lambda (search-state)
  90.     (vector-ref search-state search-state-index:end-point)))
  91.  
  92. (define-integrable search-state-point
  93.   (lambda (search-state)
  94.     (vector-ref search-state search-state-index:point)))
  95.  
  96. (define-integrable search-state-initial-point
  97.   (lambda (search-state)
  98.     (vector-ref search-state search-state-index:initial-point)))
  99.  
  100. (define-integrable search-state-successful?
  101.   (lambda (search-state)
  102.     (vector-ref search-state search-state-index:successful?)))
  103. )
  104. ;;;; Top Level
  105.  
  106.  
  107. (define (incremental-search forward?)
  108.   (let ((old-point (current-point))
  109.     (old-window (current-window)))
  110.     (let ((y-point (window-point-y old-window)))
  111.       (let ((result
  112.          (catch
  113.            (lambda (continuation)
  114.          (fluid-let ((incremental-search-exit continuation)
  115.                  (incremental-search-window old-window)
  116.                  (current-search-state #F))
  117.                    (set-current-search-state!
  118.                      (initial-search-state forward? old-point))
  119.                    (incremental-search-loop))))))
  120.     (cond ((eq? result 'ABORT)
  121.            (set-current-point! old-point)
  122.            (window-scroll-y-absolute! (current-window) y-point))
  123.           ((char? result)
  124.                (erase-echo-prompt!)
  125.            (dispatch-on-char result)))))))
  126.  
  127. (define (incremental-search-loop)
  128.   (let ((result
  129.      (catch
  130.        (lambda (continuation)
  131.          (fluid-let ((*error-continuation* continuation))
  132.            (incremental-search-command-reader))))))
  133.     (if (eq? result 'abort)           ;; Handle ^G and go on
  134.     (begin (incremental-search:pop!)
  135.            (incremental-search-loop))
  136.     result)))
  137.  
  138. (define ctrl-q (integer->char 17))
  139. (define ctrl-r (integer->char 18))
  140. (define ctrl-s (integer->char 19))
  141.  
  142. (define (incremental-search-command-reader)
  143.   (let ((char (editor-read-char (window-screen (current-window)))))
  144.     (cond ((standard-char? char) (i-search-append-char char))
  145.           ((char=? char #\Tab) (i-search-append-char char))
  146.           ((char=? char ctrl-q) (i-search-append-char
  147.                                   (read-char (window-screen (current-window)))))
  148.           ((char=? char ctrl-s)
  149.            (set-current-search-state!
  150.              (incremental-search:next-occurrence (fluid current-search-state)))
  151.            (i-search-detect-failure (fluid current-search-state)))
  152.           ((char=? char ctrl-r)
  153.            (set-current-search-state!
  154.              (incremental-search:previous-occurrence
  155.                (fluid current-search-state)))
  156.            (i-search-detect-failure (fluid current-search-state)))
  157.           ((char=? char #\backspace)
  158.            (set-current-search-state!
  159.              (incremental-search:delete-char (fluid current-search-state))))
  160.           (else (incremental-search:terminate! (fluid current-search-state)
  161.                                             char))))
  162.   (incremental-search-command-reader))
  163.  
  164. (define (standard-char? char)
  165.   (let ((i (char->integer char)))
  166.     (and (>= i 32) (<= i 126))))
  167.  
  168.  
  169. ;;;; Commands
  170.  
  171. (define (incremental-search:append-char state char)
  172.   (let ((text (string-append (search-state-text state)
  173.                              (list->string (list char)))))
  174.     (cond ((not (search-state-successful? state))
  175.        (unsuccessful-search-state state text
  176.                       (search-state-forward? state)))
  177.       ((search-state-forward? state)
  178.        (find-next-search-state state
  179.                    text
  180.                    (search-state-start-point state)))
  181.       (else
  182.        (find-previous-search-state
  183.         state text
  184.         (let ((end (search-state-end-point state)))
  185.           (if (or (group-end? end)
  186.               (mark= end (search-state-initial-point state)))
  187.           end
  188.           (mark1+ end #F))))))))
  189.  
  190. (define (incremental-search:delete-char state)
  191.   (let ((parent (search-state-parent state)))
  192.     (if (null? parent) (editor-error))
  193.     parent))
  194.  
  195. (define (incremental-search:next-occurrence state)
  196.   (cond ((null? (search-state-parent state))
  197.      (let ((point (search-state-initial-point state)))
  198.        (if (not (search-state-forward? state))
  199.            (initial-search-state #F point)
  200.                (find-next-search-state state
  201.                  previous-successful-search-string
  202.                  point))))
  203.     ((search-state-successful? state)
  204.      (find-next-search-state state
  205.                  (search-state-text state)
  206.                  ((if (search-state-forward? state)
  207.                       search-state-end-point
  208.                       search-state-start-point)
  209.                   state)))
  210.     ((not (search-state-forward? state))
  211.      (find-next-search-state state
  212.                  (search-state-text state)
  213.                  (search-state-point state)))
  214.     (else
  215.      (unsuccessful-search-state state (search-state-text state) #T))))
  216.  
  217. (define (incremental-search:previous-occurrence state)
  218.   (cond ((null? (search-state-parent state))
  219.      (let ((point (search-state-initial-point state)))
  220.        (if (search-state-forward? state)
  221.            (initial-search-state #F point)
  222.                (find-previous-search-state state
  223.                   previous-successful-search-string
  224.                   point))))
  225.     ((search-state-successful? state)
  226.      (find-previous-search-state state
  227.                      (search-state-text state)
  228.                      ((if (search-state-forward? state)
  229.                       search-state-end-point
  230.                       search-state-start-point)
  231.                       state)))
  232.     ((search-state-forward? state)
  233.      (find-previous-search-state state
  234.                      (search-state-text state)
  235.                      (search-state-point state)))
  236.     (else
  237.      (unsuccessful-search-state state (search-state-text state) #F))))
  238.  
  239. (define (incremental-search:terminate! state char)
  240.   (let ((state (most-recent-successful-search-state state)))
  241.     (if (not (null? (search-state-parent state)))
  242.     (set! previous-successful-search-string (search-state-text state))))
  243.   ((fluid incremental-search-exit) char))
  244.  
  245. (define (incremental-search:pop!)
  246.   (let ((success (most-recent-successful-search-state
  247.            (fluid current-search-state))))
  248.     (if (eq? success (fluid current-search-state))
  249.     ((fluid incremental-search-exit) 'ABORT)
  250.     (set-current-search-state! success))))
  251.  
  252. ;;;; Primitives
  253.  
  254. (define (initial-search-state forward? point)
  255.   (make-search-state "" '() forward? #T point point point point))
  256.  
  257. (define (unsuccessful-search-state parent text forward?)
  258.   (let ((start-point (search-state-start-point parent)))
  259.     (make-search-state text parent forward? #F
  260.                start-point
  261.                (mark+ start-point (string-length text) #F)
  262.                (search-state-point parent)
  263.                (search-state-initial-point parent))))
  264.  
  265. (define (find-next-search-state state text start)
  266.   (let ((start-point (find-next-string start (group-end start) text)))
  267.     (if (not start-point)
  268.     (unsuccessful-search-state state text #T)
  269.     (let ((end-point (mark+ start-point (string-length text) #F)))
  270.       (make-search-state text state #T #T
  271.                  start-point end-point end-point
  272.                  (if (search-state-forward? state)
  273.                  (search-state-initial-point state)
  274.                  (search-state-start-point state)))))))
  275.  
  276. (define (find-previous-search-state state text start)
  277.   (let ((end-point (find-previous-string start (group-start start) text)))
  278.     (if (not end-point)
  279.     (unsuccessful-search-state state text #F)
  280.     (let ((start-point (mark- end-point (string-length text) #F)))
  281.       (make-search-state text state #F #T
  282.                  start-point end-point start-point
  283.                  (if (search-state-forward? state)
  284.                  (search-state-end-point state)
  285.                  (search-state-initial-point state)))))))
  286.  
  287. (define (set-current-search-state! state)
  288.   (update-i-search-prompt state)
  289.   (set-window-point! (fluid incremental-search-window)
  290.              (search-state-point state))
  291.   (set-fluid! current-search-state state))
  292.  
  293. (define (update-i-search-prompt state)
  294.   (set-echo-prompt!
  295.     (string-append
  296.       (if (search-state-successful? state) "" "Failing ")
  297.       (if (search-state-forward? state) "" "Reverse ")
  298.       "I-Search: "
  299.       (search-state-text state))))
  300.  
  301. (define (most-recent-successful-search-state state)
  302.   (cond ((search-state-successful? state)
  303.      state)
  304.     ((null? (search-state-parent state))
  305.      (error "Search state chain terminated improperly"))
  306.     (else
  307.      (most-recent-successful-search-state (search-state-parent state)))))
  308.  
  309. (define (i-search-append-char char)
  310.   (set-current-search-state!
  311.    (incremental-search:append-char (fluid current-search-state) char))
  312.   (i-search-detect-failure (fluid current-search-state)))
  313.  
  314. (define (i-search-detect-failure search-state)
  315.   (if (and (not (search-state-successful? search-state))
  316.        (or (search-state-successful? (search-state-parent
  317.                                            search-state))
  318.            (not (eq? (search-state-forward? search-state)
  319.              (search-state-forward?
  320.               (search-state-parent search-state))))))
  321.       (beep)))
  322.  
  323.