home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / pcscheme / geneva / sources.exe / SOURCES / EDWIN / REDISP1.S < prev    next >
Encoding:
Text File  |  1993-08-21  |  14.2 KB  |  431 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 10/21/85
  39. ;;;
  40. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  41.  
  42.  
  43. ;;; define-integrables
  44. (begin
  45. (define-integrable inferior:x-start cddr)
  46. (define-integrable inferior:y-start cadr)
  47. (define-integrable inferior:line caar)
  48. (define-integrable inferior:y-size cdar)
  49. (define-integrable set-inferior:x-start!
  50.   (lambda (inferior val)
  51.     (set-cdr! (cdr inferior) val)))
  52.  
  53. (define-integrable set-inferior:y-start!
  54.   (lambda (inferior val)
  55.     (set-car! (cdr inferior) val)))
  56.  
  57. (define-integrable set-inferior:line!
  58.   (lambda (inferior val)
  59.     (set-car! (car inferior) val)))
  60.  
  61. (define-integrable set-inferior:y-size!
  62.   (lambda (inferior val)
  63.     (set-cdr! (car inferior) val)))
  64.  
  65. (define-integrable screen:cursor-y 0)
  66. (define-integrable screen:cursor-x 1)
  67. (define-integrable screen:x-size 5)
  68. (define-integrable screen:y-size 4)
  69. (define-integrable window:point 0)
  70. (define-integrable window:lines 1)
  71. (define-integrable window:map 2)
  72. (define-integrable window:screen 3)
  73. (define-integrable window:y-size 4)
  74. (define-integrable window:start 5)
  75. (define-integrable window:end 6)
  76. (define-integrable window:buffer 7)
  77. (define-integrable window:cursor-x 8)
  78. (define-integrable window:cursor-y 9)
  79. (define-integrable window:redisplay-window-flag 10)
  80. (define-integrable window:redisplay-cursor-flag 11)
  81. (define-integrable window:start-mark 12)
  82. (define-integrable window:end-mark 13)
  83. (define-integrable window:last-inferior-y 14)
  84.  
  85. (define-integrable window-point
  86.   (lambda (window)
  87.     (vector-ref window window:point)))
  88.  
  89. (define-integrable window-point-x
  90.   (lambda (window)
  91.     (vector-ref window window:cursor-x)))
  92.  
  93. (define-integrable window-point-y
  94.   (lambda (window)
  95.     (vector-ref window window:cursor-y)))
  96.  
  97. (define-integrable window-buffer
  98.   (lambda (window)
  99.     (vector-ref window window:buffer)))
  100.  
  101. (define-integrable window-screen
  102.   (lambda (window)
  103.     (vector-ref window window:screen)))
  104.  
  105. (define-integrable window-y-size
  106.   (lambda (window)
  107.     (vector-ref window window:y-size)))
  108.  
  109. (define-integrable ncols
  110.   (lambda ()
  111.      (cdr (window-get-size 'console))))
  112.  
  113. (define-integrable nlines
  114.   (lambda ()
  115.      edwin-maxlines))
  116.  
  117. (define-integrable window-x-size
  118.   (lambda (window)
  119.     (ncols)))
  120. )
  121.  
  122. (define update-cursor!
  123.   (lambda (window)
  124.     (let ((screen (vector-ref window window:screen))
  125.       (x (vector-ref window window:cursor-x))
  126.       (y (vector-ref window window:cursor-y)))
  127.       (vector-set! window window:redisplay-cursor-flag #F)
  128.       (if (and (not (negative? x))
  129.            (not (negative? y)))
  130.           (set-screen-cursor! screen x y)))))
  131.  
  132. (define (set-screen-cursor! screen x y)
  133.   (%reify-port! screen screen:cursor-x x)
  134.   (%reify-port! screen screen:cursor-y y))
  135.  
  136. (define set-cursor-pos
  137.   (lambda (window x y)
  138.     (vector-set! window window:cursor-x x)
  139.     (vector-set! window window:cursor-y y)
  140.     (vector-set! window window:redisplay-cursor-flag #T)))
  141.  
  142. (define write-string!
  143.   (lambda (screen string x y)
  144.     (set-screen-cursor! screen x y)
  145.     (princ string screen)))
  146.  
  147.  
  148.  
  149. (define (make-buffer-window screen buffer)
  150.  (define (setup-inferior-table table y-size)
  151.    (do ((i 0 (1+ i))
  152.     (table table))
  153.        ((= i y-size) table)
  154.      (vector-set! table i (cons (cons #F #F) (cons i 0)))))
  155.  
  156.  (define initialize!
  157.    (lambda (window buffer)
  158.      (add-buffer-window! buffer window)
  159. ;;;; this is for the speed up hack insertch.scm
  160.      (%create-char-daemon window)
  161.      (let ((group (buffer-group buffer)))
  162.        (add-group-delete-daemon! group (make-delete-daemon window))
  163.        (add-group-insert-daemon! group (make-insert-daemon window)))
  164.      (vector-set! window window:point (buffer-point buffer))))
  165.  
  166.   (let ((window (make-vector 15 #F))
  167.     (start-buffer (buffer-start buffer))
  168.     (y-size (%reify-port screen screen:y-size)))
  169.     (let ((table (setup-inferior-table (make-vector y-size) y-size)))
  170.       (vector-set! window window:y-size y-size)
  171.       (vector-set! window window:lines table)
  172.       (vector-set! window window:screen screen)
  173.       (vector-set! window window:buffer buffer)
  174.       (update-bottom-inferior! (mark-line start-buffer) 0 0
  175.                    (vector-ref table 0) table y-size)
  176.       (map-changed! window)
  177.       (vector-set! window window:start 0)
  178.       (vector-set! window window:end 0)
  179.       (vector-set! window window:cursor-x 0)
  180.       (vector-set! window window:cursor-y 0)
  181.       (vector-set! window window:start-mark start-buffer)
  182.       (vector-set! window window:end-mark start-buffer)
  183.       (vector-set! window window:last-inferior-y 0)
  184.       (initialize! window buffer)
  185.       window)))
  186.  
  187. (define window-y-size-changed
  188.   (lambda (window)
  189.     (vector-set! window window:y-size
  190.          (%reify-port (vector-ref window window:screen)
  191.                   screen:y-size))
  192.     (vector-set! window window:map '())
  193.     (window-redraw! window)))
  194.  
  195.  
  196. (define line->y
  197.   (lambda (window line)
  198.     (let ((entry (assq line (vector-ref window window:map))))
  199.       (and entry
  200.        (cdr entry)))))
  201.  
  202. (define set-window-point!
  203.   (lambda (window mark)
  204.     (let ((buffer (vector-ref window window:buffer)))
  205.       (set-buffer-point! buffer mark)
  206.       (vector-set! window window:point (buffer-point buffer))
  207.       (cursor-moved! window))))
  208.  
  209. (define cursor-moved!
  210.   (lambda (window)
  211.     (let ((point (vector-ref window window:point)))
  212.       (if (window-mark-visible? window point)
  213.       (set-cursor-coordinates window point)
  214.       (window-redraw! window)))))
  215.  
  216.  
  217. (define (map-changed! window)
  218.   (define (loop tail n table y-size)
  219.     (if (or (>= n y-size)
  220.         (null? (inferior:line (vector-ref table n))))
  221.     tail
  222.     (let ((inferior (vector-ref table n)))
  223.       (loop (cons (cons (inferior:line inferior) n)
  224.               tail)
  225.         (+ (inferior:y-start inferior) (inferior:y-size inferior))
  226.         table y-size))))
  227.   (let ((map (loop '() 0 (vector-ref window window:lines)
  228.            (vector-ref window window:y-size))))
  229.     (vector-set! window window:map map)
  230.     (vector-set! window window:last-inferior-y (cdar map))))
  231.  
  232. (define clear-subscreen!
  233.   (lambda (screen xl yl lin col)
  234.     (let ((sxl    (%reify-port screen 3))
  235.       (syl    (%reify-port screen 2))
  236.       (slin (%reify-port screen 4))
  237.       (scol (%reify-port screen 5))
  238.       (change-cord
  239.          (lambda (x y l c)
  240.            (%reify-port! screen 3 x)
  241.            (%reify-port! screen 2 y)
  242.            (%reify-port! screen 4 l)
  243.            (%reify-port! screen 5 c))))
  244.       (change-cord (+ sxl xl) (+ syl yl) lin col)
  245.       (%clear-window screen)
  246.       (change-cord sxl syl slin scol))))
  247.  
  248. (define (redisplay window table start end)
  249.   (let loop ((screen (window-screen window)) (n start) (end end)
  250.          (table table) (y-size (vector-ref window window:y-size)))
  251.        (if (> n end)
  252.       '()
  253.       (let ((inferior (vector-ref table n)))
  254.         (if (inferior:line inferior)
  255.         (begin
  256.          (let ((y-start (inferior:y-start inferior))
  257.                (ys  (inferior:y-size inferior))
  258.                (string (line-string (inferior:line inferior))))
  259.            (set-screen-cursor! screen 0 (max 0 y-start))
  260.            (%substring-display string 0 (string-length string) y-start
  261.                     screen)
  262.            (loop screen (+ y-start ys) end table y-size)))
  263.         (clear-subscreen! screen 0 n (1+ (- end n)) (ncols)))))))
  264.  
  265. (define update-window!
  266.   (lambda (window)
  267.     (let ((table (vector-ref window window:lines))
  268.       (start (vector-ref window window:start))
  269.       (end     (vector-ref window window:end)))
  270.       (redisplay window table start end)
  271.       (vector-set! window window:redisplay-window-flag #F))))
  272.  
  273. (define update-display!
  274.   (lambda (window)
  275.     (if (vector-ref window window:redisplay-window-flag)
  276.     (update-window! window))
  277.     (if (vector-ref window window:redisplay-cursor-flag)
  278.     (update-cursor! window))))
  279.  
  280. (define reset-buffer-window
  281.   (lambda (window)
  282.     (vector-set! window window:start 0)
  283.     (vector-set! window window:end
  284.          (-1+ (vector-ref window window:y-size)))
  285.     (vector-set! window window:redisplay-window-flag #T)
  286.     (vector-set! window window:redisplay-cursor-flag #T)
  287.     (update-display! window)))
  288.  
  289.  
  290. ;;; redisp2
  291.  
  292. (define window-redraw!
  293.   (letrec ((%receiver (lambda (w) (error "window-redraw"))))
  294.     (lambda (window)
  295.       (let ((mark (vector-ref window window:point))
  296.         (y (quotient (vector-ref window window:y-size) 2)))
  297.     (set-start-end! window 0 (-1+ (vector-ref window window:y-size)))
  298.     (redraw-screen! window mark y)
  299.     (everything-changed! window %receiver)))))
  300.  
  301. (define redraw-screen!
  302.   (lambda (window mark y)
  303.     (let ((line (mark-line mark))
  304.       (table (vector-ref window window:lines))
  305.       (y-size (vector-ref window window:y-size))
  306.       (position (mark-position mark))
  307.       (string (line-string (mark-line mark))))
  308.       (let ((y* (index->y (char->x string position) 80 position string)))
  309.     (let ((start (max 0 (- y y*)))
  310.           (ys (find-y-size line))
  311.           (y-start (- y y*)))
  312.     (clean-up-table table 0 y-size)
  313.     (update-inferior! line 0 y-start ys (vector-ref table start))
  314.     (if (> ys 1)
  315.         (fill-entries (1+ start) (min y-size (+ y-start ys))
  316.               start table y-size))
  317.     (fill-top! window line table y-size start #T))))))
  318.  
  319. (define everything-changed!
  320.   (lambda (window if-not-visible)
  321.     (map-changed! window)
  322.     (start-mark-changed! window)
  323.     (end-mark-changed! window)
  324.     (if (window-mark-visible? window (vector-ref window window:point))
  325.     (begin
  326.       (cursor-moved! window))
  327.     (if-not-visible window))))
  328.  
  329. (define (window-mark-visible? window mark)
  330.   (and (mark<= (vector-ref window window:start-mark) mark)
  331.        (mark<= mark (vector-ref window window:end-mark))))
  332.  
  333. (define (line-visible? window point)
  334.   (assq (mark-line point)
  335.     (vector-ref window window:map)))
  336.  
  337.  
  338. ;;; coordinates
  339.  
  340. (define window-coordinates->mark
  341.   (lambda (window x y)
  342.     (let* ((table (vector-ref window window:lines))
  343.        (inferior (vector-ref table y)))
  344.       (make-mark (inferior:line inferior)
  345.          (x->char (line-string (inferior:line inferior))
  346.               (+ x (* (- y (inferior:y-start inferior)) (-1+ (ncols)))))))))
  347.  
  348. (define (start-mark-changed! window)
  349.   (vector-set! window window:start-mark
  350.            (window-coordinates->mark window 0 0)))
  351.  
  352. (define (end-mark-changed! window)
  353.   (let ((inferior (vector-ref (vector-ref window window:lines)
  354.                   (vector-ref window window:last-inferior-y)))
  355.     (y-size (vector-ref window window:y-size)))
  356.     (let ((line (inferior:line inferior))
  357.       (y-start (inferior:y-start inferior))
  358.       (ys  (inferior:y-size inferior)))
  359.       (vector-set! window window:end-mark
  360.     (make-mark
  361.       line
  362.       (end-column->index
  363.        (line-string line)
  364.        (+ (-1+ (ncols)) (* (- (-1+ (min y-size (+ y-start ys))) y-start) (-1+ (ncols))))))
  365.     ))))
  366.  
  367. (define (maybe-marks-changed window y)
  368.   (if (= y 0)
  369.       (start-mark-changed! window))
  370.   (if (= y (vector-ref window window:last-inferior-y))
  371.       (end-mark-changed! window)))
  372.  
  373.  
  374. ;;; index->column
  375.  
  376. (define (char->x string char-no)
  377.   (let loop ((start 0)(tot 0)(end char-no)(string string))
  378.        (let ((index (substring-find-next-char-in-set string start end
  379.                              non-graphic-chars)))
  380.      (if index
  381.          (let ((tot (+ tot (- index start))))
  382.            (loop (1+ index)
  383.              (+ tot (if (char-ci=? #\tab (string-ref string index))
  384.                 (- 8 (remainder tot 8))
  385.                 2))
  386.              end string))
  387.          (+ tot (- end start))))))
  388.  
  389. ;;; column->index
  390.  
  391. (define (x->char string column)
  392.   (let loop ((string string)(start 0)(c 0)(end (string-length string))
  393.          (column column))
  394.        (let ((i (substring-find-next-char-in-set string start end
  395.                          non-graphic-chars)))
  396.      (if i
  397.          (let ((new-c (+ c (- i start))))
  398.            (if (<= column new-c)
  399.            (+ start (- column c))
  400.            (let ((new-c (+ new-c
  401.                    (if (char-ci=? #\tab (string-ref string i))
  402.                        (- 8 (remainder new-c 8))
  403.                        2))))
  404.              (if (<= column new-c)
  405.              (1+ i)
  406.              (loop string (1+ i) new-c end column)))))
  407.          (min (+ start (- column c)) end)))))
  408.  
  409. (define (end-column->index string column)
  410.   (let loop ((string string)(start 0)(c 0)(end (string-length string))
  411.          (column column))
  412.        (let ((i (substring-find-next-char-in-set string start end
  413.                          non-graphic-chars)))
  414.      (if i
  415.          (let ((new-c (+ c (- i start))))
  416.            (if (<= column new-c)
  417.            (+ start (- column c))
  418.            (let ((new-c (+ new-c
  419.                    (if (char-ci=? #\tab (string-ref string i))
  420.                        (- 8 (remainder new-c 8))
  421.                        2))))
  422.              (cond ((< column new-c) i)
  423.                ((= column new-c)
  424.                 (if (= 1 (- end i)) (1+ i) i))
  425.                (else (loop string (1+ i) new-c end column))))))
  426.              (let ((i (+ start (- column c))))
  427.                (cond ((< end i) end)
  428.                      ((= end i) end)
  429.                      (else (-1+ i))))))))
  430.  
  431.