home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / pcscheme / geneva / sources.exe / SOURCES / EDWIN / THINGS.S < prev    next >
Encoding:
Text File  |  1993-06-15  |  8.6 KB  |  231 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. ;;;; Textual Entities
  44.  
  45. ;;;; Motion Primitives
  46.  
  47. ;;; This file "defines" various kinds of things like lines, pages,
  48. ;;; words, etc.  The "definition" of a FOO entity consists of two
  49. ;;; procedures, FORWARD-FOO and BACKWARD-FOO, each of which takes
  50. ;;; three arguments: [1] a mark to start from, [2] the number of FOOs
  51. ;;; to traverse, and [3] a limit for LIMIT-MARK-MOTION.  The value of
  52. ;;; the procedure should be either a mark or #F.
  53.  
  54. ;;; If the number is positive, traverse that many FOOs in the given
  55. ;;; direction; if negative, in the opposite direction; and zero means
  56. ;;; don't move.  It is assumed that no two FOOs overlap; they may or
  57. ;;; may not touch one another.  When moving forward, stop to the right
  58. ;;; of the rightmost edge of the FOO.  When moving backward, stop to
  59. ;;; the left of the leftmost edge.
  60.  
  61. ;;; MAKE-MOTION-PAIR will generate these two procedures, given the
  62. ;;; simpler primitives to move forward or backward once.
  63.  
  64. (define (move-thing forward-thing argument)
  65.   (set-current-point! (forward-thing (current-point) argument 'BEEP)))
  66.  
  67. (define (make-motion-pair forward-one-thing backward-one-thing receiver)
  68.   (define (forward-thing mark n limit?)
  69.     (cond ((positive? n) (%forward-thing mark n limit?))
  70.       ((negative? n) (%backward-thing mark (- n) limit?))
  71.       (else mark)))
  72.  
  73.   (define (%forward-thing mark n limit?)
  74.     (define (loop mark n)
  75.       (let ((end (forward-one-thing mark (group-end mark))))
  76.     (cond ((not end) (limit-mark-motion limit? mark))
  77.           ((= n 1) end)
  78.           (else (loop end (-1+ n))))))
  79.     (loop mark n))
  80.  
  81.   (define (backward-thing mark n limit?)
  82.     (cond ((positive? n) (%backward-thing mark n limit?))
  83.       ((negative? n) (%forward-thing mark (- n) limit?))
  84.       (else mark)))
  85.  
  86.   (define (%backward-thing mark n limit?)
  87.     (define (loop mark n)
  88.       (let ((start (backward-one-thing mark (group-start mark))))
  89.     (cond ((not start) (limit-mark-motion limit? mark))
  90.           ((= n 1) start)
  91.           (else (loop start (-1+ n))))))
  92.     (loop mark n))
  93.  
  94.   (receiver forward-thing backward-thing))
  95.  
  96. ;;;; Generic Operations
  97.  
  98. (define (move-thing-saving-point forward-thing argument)
  99.   (let ((mark (current-point)))
  100.     (push-current-mark! mark)
  101.     (set-current-point! (forward-thing mark argument 'BEEP))))
  102.  
  103. (define (mark-thing forward-thing n)
  104.   (push-current-mark! (forward-thing (current-point) n 'ERROR)))
  105.  
  106. (define (kill-thing forward-thing n)
  107.   (kill-region (forward-thing (current-point) n 'ERROR)))
  108.  
  109. ;;;(define (transpose-things forward-thing n)
  110. ;;;  (define (forward-once i)
  111. ;;;    (let ((m4 (mark-right-inserting (forward-thing (current-point) 1 'ERROR))))
  112. ;;;      (set-current-point! m4)
  113. ;;;      (let ((m2 (mark-permanent! (forward-thing m4 -1 'ERROR))))
  114. ;;;    (let ((m1 (mark-permanent! (forward-thing m2 -1 'ERROR))))
  115. ;;;      (let ((m3 (forward-thing m1 1 'ERROR)))
  116. ;;;        (region-insert! m4 (region-extract! (make-region m1 m3)))
  117. ;;;        (region-insert! m1 (region-extract! (make-region m2 m4))))))))
  118. ;;;
  119. ;;;  (define (backward-once i)
  120. ;;;    (let ((m2 (mark-permanent! (forward-thing (current-point) -1 'ERROR))))
  121. ;;;      (let ((m1 (mark-left-inserting (forward-thing m2 -1 'ERROR))))
  122. ;;;    (let ((m3 (forward-thing m1 1 'ERROR))
  123. ;;;          (m4 (mark-right-inserting (forward-thing m2 1 'ERROR))))
  124. ;;;        (region-insert! m4 (region-extract! (make-region m1 m3)))
  125. ;;;        (region-insert! m1 (region-extract! (make-region m2 m4))))
  126. ;;;    (set-current-point! m1))))
  127. ;;;
  128. ;;;  (define (special)
  129. ;;;    (let ((m1 (normalize (current-point)))
  130. ;;;      (m2 (normalize (current-mark))))
  131. ;;;      (cond ((mark< m1 m2)
  132. ;;;         (exchange m1 m2
  133. ;;;               (lambda (m1 m2)
  134. ;;;             (set-current-point! m2)
  135. ;;;             (set-current-mark! m1))))
  136. ;;;        ((mark< m2 m1)
  137. ;;;         (exchange m2 m1
  138. ;;;               (lambda (m2 m1)
  139. ;;;             (set-current-point! m2)
  140. ;;;             (set-current-mark! m1)))))))
  141. ;;;
  142. ;;;  (define (exchange m1 m2 receiver)
  143. ;;;    (let ((m1 (mark-right-inserting m1))
  144. ;;;      (m3 (forward-thing m1 1 'ERROR))
  145. ;;;      (m2 (mark-permanent! m2))
  146. ;;;      (m4 (mark-right-inserting (forward-thing m2 1 'ERROR))))
  147. ;;;      (region-insert! m4 (region-extract! (make-region m1 m3)))
  148. ;;;      (region-insert! m1 (region-extract! (make-region m2 m4)))
  149. ;;;      (receiver m4 m1)))
  150. ;;;
  151. ;;;  (define (normalize m)
  152. ;;;    (forward-thing (forward-thing m 1 'ERROR) -1 'ERROR))
  153. ;;;
  154. ;;;  (cond ((positive? n) (dotimes n forward-once))
  155. ;;;    ((negative? n) (dotimes (- n) backward-once))
  156. ;;;    (else (special))))
  157.  
  158. ;;;; Horizontal Space
  159.  
  160. (define (region-blank? region)
  161.   (not (find-next-non-blank (region-start region)
  162.                 (region-end region)
  163.                 #F)))
  164.  
  165. (define (line-blank? mark)
  166.   (not (find-next-non-blank (line-start mark 0 #F)
  167.                 (line-end mark 0 #F)
  168.                 #F)))
  169.  
  170. (define (horizontal-space-region mark)
  171.   (make-region (horizontal-space-start mark)
  172.            (horizontal-space-end mark)))
  173.  
  174. (define (horizontal-space-start mark)
  175.   (find-previous-non-blank mark (line-start mark 0 #F) 'LIMIT))
  176.  
  177. (define (horizontal-space-end mark)
  178.   (find-next-non-blank mark (line-end mark 0 #F) 'LIMIT))
  179.  
  180. ;(define (compute-horizontal-space c1 c2 receiver)
  181. ;;;  ;; Compute the number of tabs/spaces required to fill from column C1
  182. ;;;  ;; to C2 with whitespace.  It is assumed that C1 >= C2.
  183. ;;;  (if indent-tabs-mode
  184. ;;;      (let ((qr (integer-divide c2 tab-width)))
  185. ;;;    (receiver (- (integer-divide-quotient qr) (quotient c1 tab-width))
  186. ;;;          (integer-divide-remainder qr)))
  187. ;;;      (receiver (- c2 c1) 0)))
  188. ;;;
  189. ;;;(define (insert-horizontal-space target-column #!optional point)
  190. ;;;  (set! point
  191. ;;;    (if (unassigned? point) (current-point) (mark-left-inserting point)))
  192. ;;;  (compute-horizontal-space (mark-column point) target-column
  193. ;;;    (lambda (n-tabs n-spaces)
  194. ;;;      (insert-chars #\Tab n-tabs point)
  195. ;;;      (insert-chars #\Space n-spaces point))))
  196.  
  197. (define (delete-horizontal-space)
  198.   (let ((point (current-point)))
  199.     (region-delete! (horizontal-space-region point))))
  200.  
  201. (define find-next-non-blank (char-set-forward-search char-set:non-blanks))
  202. (define find-previous-non-blank (char-set-backward-search char-set:non-blanks))
  203.  
  204.  
  205. ;;;; Lines
  206. ; I could not find any calls to the following functions, so I commented
  207. ; them out. Note, they must have the #!optional fixed before they are added
  208. ; back in
  209.  
  210. ;;;(define (forward-line mark n #!optional limit?)
  211. ;;;  (if (unassigned? limit?) (set! limit? #F))
  212. ;;;  (cond ((positive? n) (%forward-line mark n limit?))
  213. ;;;    ((negative? n) (%backward-line mark (- n) limit?))
  214. ;;;    (else mark)))
  215.  
  216. ;;;(define %forward-line
  217. ;;;  line-start)
  218.  
  219. ;;;(define (backward-line mark n #!optional limit?)
  220. ;;;  (if (unassigned? limit?) (set! limit? #F))
  221. ;;;  (cond ((positive? n) (%backward-line mark n limit?))
  222. ;;;    ((negative? n) (%forward-line mark (- n) limit?))
  223. ;;;    (else mark)))
  224.  
  225. ;;;(define (%backward-line mark n limit?)
  226. ;;;  (line-start mark
  227. ;;;          (- (if (line-start? mark)
  228. ;;;             n
  229. ;;;             (-1+ n)))
  230. ;;;              limit?))
  231.