home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / pcscheme / geneva / sources.exe / SOURCES / EDWIN / REGOPS.S < prev    next >
Encoding:
Text File  |  1993-06-15  |  14.1 KB  |  406 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. ;;;; Region Operations
  44.  
  45. ;;;; String <-> Region
  46.  
  47. (define (string->region string)
  48.   (substring->region string 0 (string-length string)))
  49.  
  50. (define (substring->region string start end)
  51.   (let ((nl (substring-find-next-char string start end #\Newline)))
  52.     (if (not nl)
  53.         (let ((line (make-line (substring string start end))))
  54.        (lines->region line line))
  55.     (let ((first-line (make-line (substring string start nl)))
  56.           (group (make-group #F)))
  57.       (define (loop previous-line n start)
  58.         (let ((nl (substring-find-next-char string start end #\Newline)))
  59.           (if (not nl)
  60.           (let ((last-line (make-line (substring string start end))))
  61.             (connect-lines! previous-line last-line)
  62.             (set-line-group! last-line group)
  63.             (set-line-number! last-line n)
  64.             (let ((region
  65.                (components->region first-line 0 last-line
  66.                            (line-length last-line))))
  67.               (%set-group-region! group region)
  68.               region))
  69.           (let ((this-line (make-line (substring string start nl))))
  70.             (connect-lines! previous-line this-line)
  71.             (set-line-group! this-line group)
  72.             (set-line-number! this-line n)
  73.             (loop this-line (+ n line-number-increment) (1+ nl))))))
  74.       (set-line-group! first-line group)
  75.       (set-line-number! first-line 0)
  76.       (loop first-line line-number-increment (1+ nl))))))
  77.  
  78. (define (region->string region)
  79.   (region-components region
  80.     (lambda (start-line start-position end-line end-position)
  81.       (if (eq? start-line end-line)
  82.       (substring (line-string start-line) start-position end-position)
  83.       (let ((result (string-allocate (region-count-chars region))))
  84.         (define (loop target line)
  85.           (string-set! result target #\Newline)
  86.           (if (eq? line end-line)
  87.           (substring-move-right! (line-string end-line) 0 end-position
  88.                      result (1+ target))
  89.           (begin (substring-move-right! (line-string line) 0
  90.                         (line-length line)
  91.                         result (1+ target))
  92.              (loop (+ target (line-length line) 1)
  93.                    (line-next line)))))
  94.         (substring-move-right! (line-string start-line) start-position
  95.                    (line-length start-line) result 0)
  96.         (loop (- (line-length start-line) start-position)
  97.           (line-next start-line))
  98.         result)))))
  99.  
  100. ;;;; Copy Region
  101.  
  102. (define (region-copy region)
  103.   (region-components region
  104.     (lambda (start-line start-position end-line end-position)
  105.       (if (eq? start-line end-line)
  106.       (let ((line (subline start-line start-position end-position)))
  107.             (lines->region line line))
  108.       (let ((new-start (subline start-line
  109.                     start-position
  110.                     (line-length start-line)))
  111.         (group (make-group #F)))
  112.         (define (loop this-line n new-previous)
  113.           (if (eq? this-line end-line)
  114.           (let ((new-end (subline end-line 0 end-position)))
  115.             (connect-lines! new-previous new-end)
  116.             (set-line-group! new-end group)
  117.             (set-line-number! new-end n)
  118.             (let ((region
  119.                (components->region new-start 0
  120.                            new-end (line-length new-end))))
  121.               (%set-group-region! group region)
  122.               region))
  123.           (let ((new-this (line-copy this-line)))
  124.             (connect-lines! new-previous new-this)
  125.             (set-line-group! new-this group)
  126.             (set-line-number! new-this n)
  127.             (loop (line-next this-line)
  128.               (+ n line-number-increment)
  129.               new-this))))
  130.         (set-line-group! new-start group)
  131.         (set-line-number! new-start 0)
  132.         (loop (line-next start-line)
  133.           line-number-increment
  134.           new-start))))))
  135.  
  136. ;;;; Extract Region
  137.  
  138. (define (region-extract! region)
  139.   (let ((sync (region-delete-starting! region)))
  140.     (let ((extracted-region (region-components region %region-extract!)))
  141.       (sync extracted-region)
  142.       extracted-region)))
  143.  
  144. (define %region-extract!
  145.   (letrec
  146.    ((%start-pos '())
  147.     (%end-pos '())
  148.     (%offset '())
  149.     (%new-line '())
  150.     (%receiver1
  151.      (lambda (mark cursor?)
  152.        (cond ((> (mark-position mark) %end-pos)
  153.           (set-mark-position! mark (- (mark-position mark) %offset)))
  154.          ((> (mark-position mark) %start-pos)
  155.           (set-mark-position! mark %start-pos)))))
  156.  
  157.     (%receiver2
  158.      (lambda (mark cursor?)
  159.        ((if cursor? %set-mark-line! set-mark-line!) mark %new-line)
  160.        (set-mark-position! mark
  161.                (if (> (mark-position mark) %end-pos)
  162.                    (- (mark-position mark) %offset)
  163.                    %start-pos))))
  164.  
  165.     (%receiver3
  166.      (lambda (mark cursor?)
  167.        ((if cursor? %set-mark-line! set-mark-line!) mark %new-line)
  168.        (set-mark-position! mark %start-pos)))
  169.  
  170.     (%receiver4
  171.      (lambda (mark cursor?)
  172.        ((if cursor? %set-mark-line! set-mark-line!) mark %new-line)
  173.        (if (> (mark-position mark) %start-pos)
  174.        (set-mark-position! mark %start-pos)))))
  175.  
  176.    (lambda (start-line start-pos end-line end-pos)
  177.      (letrec
  178.       ((move-marks!
  179.     (lambda (line)
  180.       (if (eq? line end-line)
  181.           (for-each-mark! end-line %receiver2)
  182.           (begin (for-each-mark! line %receiver3)
  183.              (move-marks! (line-next line)))))))
  184.       (set! %start-pos start-pos)
  185.       (set! %end-pos end-pos)
  186.       (if (eq? start-line end-line)
  187.       (let ((offset (- end-pos start-pos)))
  188.         (set! %offset offset)
  189.         (for-each-mark! start-line %receiver1)
  190.         (let ((line (subline-extract! start-line start-pos end-pos)))
  191.           (lines->region line line)))
  192.       (let ((new-line (line-extract! start-line start-pos end-line end-pos))
  193.         (offset (- end-pos start-pos))
  194.         (start-previous (line-previous start-line))
  195.         (end-next (line-next end-line)))
  196.         (set! %new-line new-line)
  197.         (set! %offset offset)
  198.         (for-each-mark! start-line %receiver4)
  199.         (move-marks! (line-next start-line))
  200.         (set-line-group! new-line (line-group start-line))
  201.             (set! %new-line '())
  202.         (disconnect-lines! start-line end-line)
  203.         (connect-lines! start-previous new-line)
  204.         (connect-lines! new-line end-next)
  205.         (number-lines! new-line new-line)
  206.         (lines->region start-line end-line)))))))
  207.  
  208. ;;;; Insert Region
  209.  
  210. (define (region-insert! mark region)
  211.   (let ((sync (region-insert-starting! mark)))
  212.     (let ((region*
  213.             (region-components region
  214.               (lambda (start-line start-pos end-line end-pos)
  215.                 ((lambda (line pos)
  216.            (%region-insert! line pos
  217.                     start-line start-pos
  218.                     end-line end-pos))
  219.                  (mark-line mark) (mark-position mark) )))))
  220.       (sync region*)
  221.        region*)))
  222.  
  223. (define %region-insert!
  224.   (letrec
  225.     ((%pos '())
  226.      (%offset '())
  227.      (%end-line '())
  228.      (%end-pos '())
  229.      (%receiver1
  230.       (lambda (mark cursor?)
  231.     (if (or (> (mark-position mark) %pos)
  232.         (and (= (mark-position mark) %pos)
  233.              (mark-left-inserting? mark)))
  234.         (set-mark-position! mark (+ (mark-position mark) %offset)))))
  235.  
  236.      (%receiver2
  237.       (lambda (mark cursor?)
  238.     (cond ((> (mark-position mark) %pos)
  239.            ((if cursor? %set-mark-line! set-mark-line!) mark %end-line)
  240.            (set-mark-position! mark (+ (mark-position mark) %offset)))
  241.           ((and (= (mark-position mark) %pos)
  242.             (mark-left-inserting? mark))
  243.            ((if cursor? %set-mark-line! set-mark-line!) mark %end-line)
  244.            (set-mark-position! mark %end-pos))))))
  245.  
  246.   (lambda (line pos start-line start-pos end-line end-pos)
  247.   (set! %pos pos)
  248.   (if (eq? start-line end-line)
  249.       (let ((offset (- end-pos start-pos)))
  250.         (set! %offset offset)
  251.     (for-each-mark! line %receiver1)
  252.     (line-insert! line pos start-line start-pos end-pos)
  253.     (%make-region (%make-mark line pos #F)
  254.               (%make-mark line (+ pos offset) #T)))
  255.       (let ((offset (- end-pos pos)))
  256.         (set! %end-line end-line)
  257.         (set! %offset offset)
  258.         (set! %end-pos end-pos)
  259.     (for-each-mark! line %receiver2)
  260.     (line-splice! line pos start-line start-pos end-line end-pos)
  261.         (set! %end-line '())
  262.     (connect-lines! end-line (line-next line))
  263.     (connect-lines! line (line-next start-line))
  264.     (number-lines! (line-next line) end-line)
  265.     (%make-region (%make-mark line pos #F)
  266.               (%make-mark end-line end-pos #T)))))))
  267.  
  268. ;;; These are overwritten by the routines in insertch.scm
  269. ;;;(define (region-insert-char! mark char)
  270. ;;;  (if (char= char #\Newline)
  271. ;;;      (region-insert-newline! mark)
  272. ;;;      (let ((sync (region-insert-starting! mark)))
  273. ;;;        (let ((region (mark-components mark
  274. ;;;                        (lambda (line pos)
  275. ;;;                          (%region-insert-char! line pos char)))))
  276. ;;;          (sync region)
  277. ;;;          region))))
  278. ;;;
  279. ;;;(define (%region-insert-char! line pos char)
  280. ;;;  (for-each-mark! line
  281. ;;;    (lambda (mark)
  282. ;;;      (if (or (> (mark-position mark) pos)
  283. ;;;          (and (= (mark-position mark) pos)
  284. ;;;           (mark-left-inserting? mark)))
  285. ;;;      (set-mark-position! mark (1+ (mark-position mark))))))
  286. ;;;  (line-insert-char! line pos char)
  287. ;;;  (%make-region (%make-mark line pos #F)
  288. ;;;        (%make-mark line (1+ pos) #T)))
  289. ;;;
  290. (define (region-insert-newline! mark)
  291.   (let ((sync (region-insert-starting! mark)))
  292.     (let ((region
  293.         ((lambda (line pos)
  294.         (%region-insert-newline! line pos))
  295.              (mark-line mark) (mark-position mark))))
  296.       (sync region)
  297.       region)))
  298.  
  299. (define %region-insert-newline!
  300.   (letrec
  301.     ((%pos '())
  302.      (%new-next '())
  303.      (%receiver
  304.       (lambda (mark cursor?)
  305.     (cond ((> (mark-position mark) %pos)
  306.            ((if cursor? %set-mark-line! set-mark-line!) mark %new-next)
  307.            (set-mark-position! mark (- (mark-position mark) %pos)))
  308.           ((and (= (mark-position mark) %pos)
  309.             (mark-left-inserting? mark))
  310.            ((if cursor? %set-mark-line! set-mark-line!) mark %new-next)
  311.            (set-mark-position! mark 0))))))
  312.  
  313.   (lambda (line pos)
  314.   (let ((new-next (subline-extract! line pos (line-length line))))
  315.     (set! %pos pos)
  316.     (set! %new-next new-next)
  317.     (for-each-mark! line %receiver)
  318.     (set! %new-next '())
  319.     (connect-lines! new-next (line-next line))
  320.     (connect-lines! line new-next)
  321.     (number-lines! new-next new-next)
  322.     (%make-region (%make-mark line (line-length line) #F)
  323.           (%make-mark new-next 0 #T))))))
  324.  
  325. ;;; This should be implemented later for speed.
  326. (define region-delete!
  327.   region-extract!)
  328.  
  329. (define (region-insert mark region)
  330.   (region-insert! mark (region-copy region)))
  331.  
  332. (define (region-insert-string! mark string)
  333.   (region-insert! mark (string->region string)))
  334.  
  335.  
  336. ;;;; Line String Operations
  337.  
  338. (define (subline line start end)
  339.   (make-line (substring (line-string line) start end)))
  340.  
  341. (define (line-copy line)
  342.   (make-line (line-string line)))
  343.  
  344. (define (subline-extract! line start end)
  345.   (let ((new-line (subline line start end)))
  346.     (set-line-string! line (string-delete (line-string line) start end))
  347.     new-line))
  348.  
  349. (define (line-extract! start-line start-pos end-line end-pos)
  350.   (let ((start-string (line-string start-line))
  351.     (end-string (line-string end-line)))
  352.     (let ((AD (substring-append start-string 0 start-pos
  353.                 end-string end-pos (string-length end-string)))
  354.       (B (substring start-string start-pos (string-length start-string)))
  355.       (C (substring end-string 0 end-pos)))
  356.       (set-line-string! start-line B)
  357.       (set-line-string! end-line C)
  358.       (make-line AD))))
  359.  
  360. (define (line-insert! line1 start1 line2 start2 end2)
  361.   (set-line-string!
  362.    line1
  363.    (string-insert-substring (line-string line1) start1
  364.                 (line-string line2) start2 end2)))
  365.  
  366. (define (line-insert-char! line start char)
  367.   (set-line-string!
  368.    line
  369.    (let ((string (line-string line)))
  370.      (%string-append string 0 start
  371.                      char
  372.                      string start (string-length string)))))
  373.  
  374. (define (line-splice! line1 position1 line2 position2 line3 position3)
  375.   (let ((string1 (line-string line1))
  376.     (string2 (line-string line2))
  377.     (string3 (line-string line3)))
  378.     (set-line-string! line1
  379.               (substring-append string1 0 position1
  380.                     string2
  381.                     position2
  382.                     (string-length string2)))
  383.     (set-line-string! line3
  384.               (substring-append string3 0 position3
  385.                     string1
  386.                     position1
  387.                     (string-length string1)))))
  388.  
  389. (define (mark-left-char mark)
  390.   (cond ((group-start? mark)
  391.      (error "No left character" mark))
  392.     ((line-start? mark)
  393.      #\Newline)
  394.     (else
  395.      (string-ref (line-string (mark-line mark))
  396.              (-1+ (mark-position mark))))))
  397.  
  398. (define (mark-right-char mark)
  399.   (cond ((group-end? mark)
  400.      (error "No right character" mark))
  401.     ((line-end? mark)
  402.      #\Newline)
  403.     (else
  404.      (string-ref (line-string (mark-line mark))
  405.              (mark-position mark)))))
  406.