428 lines
14 KiB
Scheme
428 lines
14 KiB
Scheme
|
;;;
|
|||
|
|
;;; Copyright (c) 1985 Massachusetts Institute of Technology
|
|||
|
|
;;;
|
|||
|
|
;;; This material was developed by the Scheme project at the
|
|||
|
|
;;; Massachusetts Institute of Technology, Department of
|
|||
|
|
;;; Electrical Engineering and Computer Science. Permission to
|
|||
|
|
;;; copy this software, to redistribute it, and to use it for any
|
|||
|
|
;;; purpose is granted, subject to the following restrictions and
|
|||
|
|
;;; understandings.
|
|||
|
|
;;;
|
|||
|
|
;;; 1. Any copy made of this software must include this copyright
|
|||
|
|
;;; notice in full.
|
|||
|
|
;;;
|
|||
|
|
;;; 2. Users of this software agree to make their best efforts (a)
|
|||
|
|
;;; to return to the MIT Scheme project any improvements or
|
|||
|
|
;;; extensions that they make, so that these may be included in
|
|||
|
|
;;; future releases; and (b) to inform MIT of noteworthy uses of
|
|||
|
|
;;; this software.
|
|||
|
|
;;;
|
|||
|
|
;;; 3. All materials developed as a consequence of the use of
|
|||
|
|
;;; this software shall duly acknowledge such use, in accordance
|
|||
|
|
;;; with the usual standards of acknowledging credit in academic
|
|||
|
|
;;; research.
|
|||
|
|
;;;
|
|||
|
|
;;; 4. MIT has made no warrantee or representation that the
|
|||
|
|
;;; operation of this software will be error-free, and MIT is
|
|||
|
|
;;; under no obligation to provide any services, by way of
|
|||
|
|
;;; maintenance, update, or otherwise.
|
|||
|
|
;;;
|
|||
|
|
;;; 5. In conjunction with products arising from the use of this
|
|||
|
|
;;; material, there shall be no use of the name of the
|
|||
|
|
;;; Massachusetts Institute of Technology nor of any adaptation
|
|||
|
|
;;; thereof in any advertising, promotional, or sales literature
|
|||
|
|
;;; without prior written consent from MIT in each case.
|
|||
|
|
;;;
|
|||
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|||
|
|
;;;
|
|||
|
|
;;; Modified by Texas Instruments Inc 10/21/85
|
|||
|
|
;;;
|
|||
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|||
|
|
|
|||
|
|
|
|||
|
|
|
|||
|
|
(define (window-scroll-y-absolute! window y-point)
|
|||
|
|
(window-scroll-y-relative! window (- (window-point-y window) y-point)))
|
|||
|
|
|
|||
|
|
(define window-scroll-y-relative!
|
|||
|
|
(letrec ((%receiver
|
|||
|
|
(lambda (w)
|
|||
|
|
(let ((buffer (vector-ref w window:buffer))
|
|||
|
|
(table (vector-ref w window:lines)))
|
|||
|
|
(set-buffer-point! buffer (window-coordinates->mark w 0 0))
|
|||
|
|
(vector-set! w window:point (buffer-point buffer))
|
|||
|
|
(cursor-moved! w)))))
|
|||
|
|
(lambda (window y-delta)
|
|||
|
|
(cond ((negative? y-delta) (scroll-down-y! window (- y-delta)))
|
|||
|
|
((positive? y-delta) (scroll-up-y! window y-delta)))
|
|||
|
|
(if (<> y-delta 0)
|
|||
|
|
(begin
|
|||
|
|
(set-start-end! window 0 (-1+ (vector-ref window window:y-size)))
|
|||
|
|
(everything-changed! window %receiver))))))
|
|||
|
|
|
|||
|
|
|
|||
|
|
;;; Scrolling
|
|||
|
|
|
|||
|
|
;;; Scrolling down
|
|||
|
|
|
|||
|
|
(define (scroll-down-y! window y-delta)
|
|||
|
|
(define (check-y-start y-delta table y-size)
|
|||
|
|
(let ((y-start (inferior:y-start (vector-ref table y-delta))))
|
|||
|
|
(if (< y-start y-delta)
|
|||
|
|
(let ((y (max 0 y-start)))
|
|||
|
|
(fill-entries y y-delta y-delta table y-size)
|
|||
|
|
y)
|
|||
|
|
y-delta)))
|
|||
|
|
|
|||
|
|
(let ((table (vector-ref window window:lines))
|
|||
|
|
(y-size (vector-ref window window:y-size)))
|
|||
|
|
(if (< y-delta y-size)
|
|||
|
|
(begin
|
|||
|
|
(scroll-lines-down! window y-delta y-size table 0)
|
|||
|
|
(let ((y (check-y-start y-delta table y-size)))
|
|||
|
|
(fill-top! window (inferior:line (vector-ref table y))
|
|||
|
|
table y-size y #!false)))
|
|||
|
|
(redraw-screen! window
|
|||
|
|
(line-start
|
|||
|
|
(make-mark (inferior:line (vector-ref table 0)) 0)
|
|||
|
|
(- 0 y-delta) 'ERROR)
|
|||
|
|
0))))
|
|||
|
|
(define (scroll-lines-down! window y-delta y-size table y)
|
|||
|
|
(let loop ((n (-1+ (- y-size y-delta)))
|
|||
|
|
(table table))
|
|||
|
|
(if (< n y)
|
|||
|
|
'()
|
|||
|
|
(let ((inferior (vector-ref table n)))
|
|||
|
|
(if (inferior:line inferior)
|
|||
|
|
(begin
|
|||
|
|
(set-inferior:line! (vector-ref table (+ n y-delta))
|
|||
|
|
#!false)
|
|||
|
|
(exchange-inferiors table n (+ n y-delta))))
|
|||
|
|
(loop (-1+ n) table)))))
|
|||
|
|
|
|||
|
|
|
|||
|
|
(define (scroll-up-y! window y-delta)
|
|||
|
|
(let ((table (vector-ref window window:lines))
|
|||
|
|
(y-size (vector-ref window window:y-size)))
|
|||
|
|
(if (< y-delta y-size)
|
|||
|
|
(if (inferior:line (vector-ref table y-delta))
|
|||
|
|
(scroll-lines-up! window y-delta y-size table y-delta)
|
|||
|
|
'())
|
|||
|
|
(redraw-screen! window
|
|||
|
|
(line-start
|
|||
|
|
(make-mark (inferior:line (vector-ref table 0)) 0)
|
|||
|
|
y-delta 'ERROR)
|
|||
|
|
0))))
|
|||
|
|
|
|||
|
|
(define (scroll-lines-up! window y-delta y-size table y)
|
|||
|
|
(define (loop n y-size table)
|
|||
|
|
(let ((move-to (- n y-delta)))
|
|||
|
|
(if (or (>= n y-size)
|
|||
|
|
(not (inferior:line (vector-ref table n))))
|
|||
|
|
(fill-bottom! move-to y-size table
|
|||
|
|
(inferior:line (vector-ref table (-1+ move-to))))
|
|||
|
|
(begin
|
|||
|
|
(set-inferior:line! (vector-ref table move-to) #!false)
|
|||
|
|
(exchange-inferiors table move-to n)
|
|||
|
|
(loop (1+ n) y-size table)))))
|
|||
|
|
(loop y y-size table))
|
|||
|
|
|
|||
|
|
|
|||
|
|
;;; Fill top and Bottom
|
|||
|
|
|
|||
|
|
(define (fill-top! window %line table y-size n fill-bottom?)
|
|||
|
|
(define (loop y table line)
|
|||
|
|
(cond ((< y 0)
|
|||
|
|
(if fill-bottom?
|
|||
|
|
(let ((inferior (vector-ref table n)))
|
|||
|
|
(let ((ys (inferior:y-size inferior))
|
|||
|
|
(y-start (inferior:y-start inferior)))
|
|||
|
|
(fill-bottom! (+ ys y-start) y-size table %line)))))
|
|||
|
|
((null? line)
|
|||
|
|
(scroll-lines-up! window (+ y 1) y-size table (+ y 1)))
|
|||
|
|
(else
|
|||
|
|
(let ((inferior (vector-ref table y)))
|
|||
|
|
(update-top-inferior! 0 y line table inferior y-size)
|
|||
|
|
(loop (- y (inferior:y-size inferior)) table
|
|||
|
|
(line-previous line))))))
|
|||
|
|
(loop (-1+ n) table (line-previous %line)))
|
|||
|
|
|
|||
|
|
(define (update-top-inferior! x y line table inferior ys)
|
|||
|
|
(let ((y-size (find-y-size line)))
|
|||
|
|
(update-inferior! line x (1+ (- y y-size)) y-size inferior)
|
|||
|
|
(if (> y-size 1)
|
|||
|
|
(fill-entries (max 0 (1+ (- y y-size))) y y table ys))))
|
|||
|
|
|
|||
|
|
|
|||
|
|
;;; Fill Bottom
|
|||
|
|
|
|||
|
|
(define (fill-bottom! n y-size table line)
|
|||
|
|
(define (loop n line y-size table)
|
|||
|
|
(if (< n y-size)
|
|||
|
|
(let ((inferior (vector-ref table n)))
|
|||
|
|
(if (null? line)
|
|||
|
|
(begin
|
|||
|
|
(set-inferior:line! inferior #!false)
|
|||
|
|
(loop (1+ n) '() y-size table))
|
|||
|
|
(begin
|
|||
|
|
(update-bottom-inferior! line 0 n inferior table y-size)
|
|||
|
|
(loop (+ n (inferior:y-size inferior)) (line-next line)
|
|||
|
|
y-size table))))))
|
|||
|
|
(loop n (line-next line) y-size table))
|
|||
|
|
|
|||
|
|
(define (update-bottom-inferior! line x y inferior table ys)
|
|||
|
|
(let ((y-size (find-y-size line)))
|
|||
|
|
(update-inferior! line x y y-size inferior)
|
|||
|
|
(if (> y-size 1)
|
|||
|
|
(fill-entries (1+ y) (min ys (+ y y-size)) y table ys))))
|
|||
|
|
|
|||
|
|
(define (update-inferior! line x y y-size inferior)
|
|||
|
|
(set-inferior:x-start! inferior x)
|
|||
|
|
(set-inferior:y-start! inferior y)
|
|||
|
|
(set-inferior:line! inferior line)
|
|||
|
|
(set-inferior:y-size! inferior y-size))
|
|||
|
|
|
|||
|
|
;;; Fill enteries
|
|||
|
|
|
|||
|
|
(define (fill-entries start end copy-entry table ys)
|
|||
|
|
(let ((copy-entry (vector-ref table copy-entry)))
|
|||
|
|
(do ((x-start (inferior:x-start copy-entry))
|
|||
|
|
(y-start (inferior:y-start copy-entry))
|
|||
|
|
(y-size (inferior:y-size copy-entry))
|
|||
|
|
(line (inferior:line copy-entry))
|
|||
|
|
(n start (1+ n)))
|
|||
|
|
((or (>= n ys) (= n end)) #!true)
|
|||
|
|
(and (>= n 0)
|
|||
|
|
(let ((entry (vector-ref table n)))
|
|||
|
|
(set-inferior:x-start! entry x-start)
|
|||
|
|
(set-inferior:y-start! entry y-start)
|
|||
|
|
(set-inferior:y-size! entry y-size)
|
|||
|
|
(set-inferior:line! entry line))))))
|
|||
|
|
|
|||
|
|
(define (exchange-inferiors table n1 n2)
|
|||
|
|
(let ((inferior1 (vector-ref table n1))
|
|||
|
|
(inferior2 (vector-ref table n2))
|
|||
|
|
(diff (- n2 n1)))
|
|||
|
|
(set-inferior:y-start! inferior1
|
|||
|
|
(+ diff (inferior:y-start inferior1)))
|
|||
|
|
(set-inferior:y-start! inferior2
|
|||
|
|
(- (inferior:y-start inferior2) diff))
|
|||
|
|
(vector-set! table n1 inferior2)
|
|||
|
|
(vector-set! table n2 inferior1)))
|
|||
|
|
|
|||
|
|
|
|||
|
|
(define (clean-up-table table n1 n2)
|
|||
|
|
(do ((i n1 (1+ i))
|
|||
|
|
(table table))
|
|||
|
|
((= i n2) table)
|
|||
|
|
(set-inferior:line! (vector-ref table i) #!false)))
|
|||
|
|
|
|||
|
|
(define (find-y-size line)
|
|||
|
|
(let* ((string (line-string line))
|
|||
|
|
(x (char->x string (string-length string))))
|
|||
|
|
(if (zero? x)
|
|||
|
|
1
|
|||
|
|
(let ((q (quotient x 79))
|
|||
|
|
(r (remainder x 79)))
|
|||
|
|
(if (zero? r)
|
|||
|
|
q
|
|||
|
|
(1+ q))))))
|
|||
|
|
|
|||
|
|
(define (set-cursor-coordinates window mark)
|
|||
|
|
(let ((line (mark-line mark))
|
|||
|
|
(position (mark-position mark))
|
|||
|
|
(string (line-string (mark-line mark)))
|
|||
|
|
(x-size (window-x-size window))
|
|||
|
|
(table (vector-ref window window:lines)))
|
|||
|
|
(let ((y (inferior:y-start
|
|||
|
|
(vector-ref table (line->y window line))))
|
|||
|
|
|
|||
|
|
(x (char->x string position)))
|
|||
|
|
(set-cursor-pos window
|
|||
|
|
(index->x x x-size position string)
|
|||
|
|
(+ y (index->y x x-size position string))))))
|
|||
|
|
|
|||
|
|
|
|||
|
|
|
|||
|
|
(define (index->x column x-size index string)
|
|||
|
|
(if (zero? column)
|
|||
|
|
0
|
|||
|
|
(let ((r (remainder column (-1+ x-size))))
|
|||
|
|
(if (zero? r)
|
|||
|
|
(if (=? index (string-length string))
|
|||
|
|
(-1+ x-size)
|
|||
|
|
r)
|
|||
|
|
r))))
|
|||
|
|
|
|||
|
|
(define (index->y column x-size index string)
|
|||
|
|
(if (zero? column)
|
|||
|
|
0
|
|||
|
|
(let ((q (quotient column (-1+ x-size)))
|
|||
|
|
(r (remainder column (-1+ x-size))))
|
|||
|
|
(if (zero? r)
|
|||
|
|
(if (=? index (string-length string))
|
|||
|
|
(-1+ q)
|
|||
|
|
q)
|
|||
|
|
q))))
|
|||
|
|
|
|||
|
|
|
|||
|
|
(define make-insert-daemon
|
|||
|
|
(lambda (window)
|
|||
|
|
(letrec
|
|||
|
|
((%receiver
|
|||
|
|
(lambda (region)
|
|||
|
|
(region-components region
|
|||
|
|
(lambda (start-line start-position end-line end-position)
|
|||
|
|
(let* ((table (vector-ref window window:lines))
|
|||
|
|
(inferior (vector-ref table y)))
|
|||
|
|
(let ((y-size (vector-ref window window:y-size))
|
|||
|
|
(old-ys (inferior:y-size inferior))
|
|||
|
|
(new-ys (find-y-size start-line)))
|
|||
|
|
(cond
|
|||
|
|
((eq? start-line end-line)
|
|||
|
|
(if (= old-ys new-ys)
|
|||
|
|
(begin
|
|||
|
|
(maybe-marks-changed window y)
|
|||
|
|
(set-start-end! window y y)
|
|||
|
|
(cursor-moved! window))
|
|||
|
|
(begin
|
|||
|
|
(scroll-lines-down! window (- new-ys old-ys)
|
|||
|
|
y-size table
|
|||
|
|
(+ (inferior:y-start inferior) old-ys))
|
|||
|
|
(set-inferior:y-size! inferior new-ys)
|
|||
|
|
(fill-entries (1+ y)
|
|||
|
|
(+ (inferior:y-start inferior) new-ys)
|
|||
|
|
y table y-size)
|
|||
|
|
(set-start-end! window y (-1+ y-size))
|
|||
|
|
(everything-changed! window window-redraw!))))
|
|||
|
|
(else
|
|||
|
|
(update-bottom-inferior! start-line 0 y
|
|||
|
|
inferior table y-size)
|
|||
|
|
(fill-bottom! (+ y new-ys) y-size table start-line)
|
|||
|
|
(set-start-end! window y (-1+ y-size))
|
|||
|
|
(everything-changed! window window-redraw!)))))))))
|
|||
|
|
|
|||
|
|
(y '()))
|
|||
|
|
(lambda (mark)
|
|||
|
|
(if (line-visible? window mark)
|
|||
|
|
(begin
|
|||
|
|
(set! y (line->y window (mark-line mark)))
|
|||
|
|
%receiver))))))
|
|||
|
|
|
|||
|
|
|
|||
|
|
(define set-start-end!
|
|||
|
|
(lambda (window start end)
|
|||
|
|
(if (vector-ref window window:redisplay-window-flag)
|
|||
|
|
(begin
|
|||
|
|
(vector-set! window window:start
|
|||
|
|
(min start (vector-ref window window:start)))
|
|||
|
|
(vector-set! window window:end
|
|||
|
|
(max end (vector-ref window window:end))))
|
|||
|
|
(begin
|
|||
|
|
(vector-set! window window:start start)
|
|||
|
|
(vector-set! window window:end end)))
|
|||
|
|
(vector-set! window window:redisplay-window-flag #!TRUE)))
|
|||
|
|
|
|||
|
|
|
|||
|
|
|
|||
|
|
(define make-delete-daemon
|
|||
|
|
(lambda (window)
|
|||
|
|
(letrec
|
|||
|
|
((start-y '())
|
|||
|
|
(end-y '())
|
|||
|
|
(mark '())
|
|||
|
|
(%receiver
|
|||
|
|
(lambda (region)
|
|||
|
|
(let ((table (vector-ref window window:lines))
|
|||
|
|
(line (mark-line mark))
|
|||
|
|
(y-size (vector-ref window window:y-size)))
|
|||
|
|
(set! mark '()) ;; clean up
|
|||
|
|
(cond ((not start-y) ;;; deleted top
|
|||
|
|
(cond ((not end-y)
|
|||
|
|
(window-redraw! window))
|
|||
|
|
(else
|
|||
|
|
(clean-up-table table 0 y-size)
|
|||
|
|
(update-bottom-inferior! line 0 end-y
|
|||
|
|
(vector-ref table end-y) table y-size)
|
|||
|
|
(fill-top! window line table y-size end-y #!true)
|
|||
|
|
(set-start-end! window 0 (-1+ y-size))
|
|||
|
|
(everything-changed! window window-redraw!))))
|
|||
|
|
((and end-y (=? start-y end-y))
|
|||
|
|
(let ((inferior (vector-ref table start-y)))
|
|||
|
|
(let ((old-ys (inferior:y-size inferior))
|
|||
|
|
(new-ys (find-y-size line))
|
|||
|
|
(y start-y))
|
|||
|
|
(if (= old-ys new-ys)
|
|||
|
|
(begin
|
|||
|
|
(maybe-marks-changed window y)
|
|||
|
|
(set-start-end! window y y)
|
|||
|
|
(cursor-moved! window))
|
|||
|
|
(begin
|
|||
|
|
(scroll-lines-up! window (- old-ys new-ys)
|
|||
|
|
y-size table
|
|||
|
|
(+ (inferior:y-start inferior) old-ys))
|
|||
|
|
(set-inferior:y-size! inferior new-ys)
|
|||
|
|
(fill-entries (1+ y)
|
|||
|
|
(+ (inferior:y-start inferior) new-ys)
|
|||
|
|
y table y-size)
|
|||
|
|
(set-start-end! window y (-1+ y-size))
|
|||
|
|
(everything-changed! window window-redraw!))))))
|
|||
|
|
(else
|
|||
|
|
(let ((inferior (vector-ref table start-y)))
|
|||
|
|
(let ((ys (find-y-size line))
|
|||
|
|
(y start-y))
|
|||
|
|
(update-bottom-inferior! line 0 y inferior table y-size)
|
|||
|
|
(fill-bottom! (+ y ys) y-size table line)
|
|||
|
|
(set-start-end! window y (-1+ y-size))
|
|||
|
|
(everything-changed! window window-redraw!)))))))))
|
|||
|
|
|
|||
|
|
(lambda (region)
|
|||
|
|
(let ((start (region-start region))
|
|||
|
|
(end (region-end region)))
|
|||
|
|
(let ((*line (mark-line start))
|
|||
|
|
(*pos (mark-position start)))
|
|||
|
|
(set! start-y (line->y window *line))
|
|||
|
|
(set! end-y (line->y window (mark-line end)))
|
|||
|
|
(set! mark (if (and start-y end-y (= start-y end-y))
|
|||
|
|
start
|
|||
|
|
(mark-permanent! start)))
|
|||
|
|
%receiver))))))
|
|||
|
|
|
|||
|
|
|
|||
|
|
|
|||
|
|
|
|||
|
|
|
|||
|
|
(define direct-output-for-insert!
|
|||
|
|
(lambda (window char)
|
|||
|
|
(let ((x (vector-ref window window:cursor-x))
|
|||
|
|
(y (vector-ref window window:cursor-y))
|
|||
|
|
(screen (vector-ref window window:screen)))
|
|||
|
|
(maybe-marks-changed window y)
|
|||
|
|
(write-string! screen char x y )
|
|||
|
|
(vector-set! window window:cursor-x
|
|||
|
|
(1+ x)))))
|
|||
|
|
|
|||
|
|
(define direct-output-forward-character!
|
|||
|
|
(lambda (window)
|
|||
|
|
(let ((screen (vector-ref window window:screen))
|
|||
|
|
(buffer (vector-ref window window:buffer))
|
|||
|
|
(point (vector-ref window window:point))
|
|||
|
|
(x (vector-ref window window:cursor-x)))
|
|||
|
|
(set-buffer-point! buffer (mark1+ point #!false))
|
|||
|
|
(vector-set! window window:point (buffer-point buffer))
|
|||
|
|
(%reify-port! screen screen:cursor-x (1+ x))
|
|||
|
|
(vector-set! window window:cursor-x (1+ x)))))
|
|||
|
|
|
|||
|
|
(define direct-output-backward-character!
|
|||
|
|
(lambda (window)
|
|||
|
|
(let ((screen (vector-ref window window:screen))
|
|||
|
|
(buffer (vector-ref window window:buffer))
|
|||
|
|
(point (vector-ref window window:point))
|
|||
|
|
(x (vector-ref window window:cursor-x)))
|
|||
|
|
(set-buffer-point! buffer (mark-1+ point #!false))
|
|||
|
|
(vector-set! window window:point (buffer-point buffer))
|
|||
|
|
(%reify-port! screen screen:cursor-x (-1+ x))
|
|||
|
|
(vector-set! window window:cursor-x (-1+ x)))))
|
|||
|
|
|
|||
|
|
|
|||
|
|
|