/[linedit]/src/smart-terminal.lisp
ViewVC logotype

Contents of /src/smart-terminal.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.18 - (show annotations)
Sun Mar 18 01:47:36 2007 UTC (7 years, 1 month ago) by nsiivola
Branch: MAIN
CVS Tags: HEAD
Changes since 1.17: +5 -1 lines
Lispworks patch #2 by Lui Fungsin
1 ;; Copyright (c) 2003 Nikodemus Siivola
2 ;;
3 ;; Permission is hereby granted, free of charge, to any person obtaining
4 ;; a copy of this software and associated documentation files (the
5 ;; "Software"), to deal in the Software without restriction, including
6 ;; without limitation the rights to use, copy, modify, merge, publish,
7 ;; distribute, sublicense, and/or sell copies of the Software, and to
8 ;; permit persons to whom the Software is furnished to do so, subject to
9 ;; the following conditions:
10 ;;
11 ;; The above copyright notice and this permission notice shall be included
12 ;; in all copies or substantial portions of the Software.
13 ;;
14 ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
15 ;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
16 ;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
17 ;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
18 ;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
19 ;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
20 ;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
21
22 (in-package :linedit)
23
24 (defclass smart-terminal (terminal)
25 ((old-point :initform 0 :accessor old-point)
26 (old-string :initform "" :accessor old-string)
27 (old-markup :initform 0 :accessor old-markup)))
28
29 (defun set-column-address (n current)
30 (if nil
31 (ti:tputs ti:column-address n)
32 (cond ((< n current)
33 (loop repeat (- current n)
34 do (ti:tputs ti:cursor-left)))
35 ((> n current)
36 (loop repeat (- n current)
37 do (ti:tputs ti:cursor-right))))))
38
39 (defun smart-terminal-p ()
40 (and ti:cursor-up ti:cursor-down ti:clr-eos
41 (or ti:column-address (and ti:cursor-left ti:cursor-right))
42 (or ti:auto-right-margin ti:enter-am-mode)))
43
44 (defmethod backend-init ((backend smart-terminal))
45 (call-next-method)
46 (when ti:enter-am-mode
47 (ti:tputs ti:enter-am-mode)))
48
49 (defun find-row (n columns)
50 ;; 1+ includes point in row calculations
51 (ceiling (1+ n) columns))
52
53 (defun find-col (n columns)
54 (rem n columns))
55
56 (defun move-in-column (&key col vertical clear-to-eos current-col)
57 (set-column-address col current-col)
58 (if (plusp vertical)
59 (loop repeat vertical do (ti:tputs ti:cursor-up))
60 (loop repeat (abs vertical) do (ti:tputs ti:cursor-down)))
61 (when clear-to-eos
62 (ti:tputs ti:clr-eos)))
63
64 (defun fix-wraparound (start end columns)
65 ;; If final character ended in the last column the point
66 ;; will wrap around to the first column on the same line:
67 ;; hence move down if so.
68 (when (and (< start end) (zerop (find-col end columns)))
69 (ti:tputs ti:cursor-down)))
70
71 (defun place-point (&key up col)
72 (loop repeat up do (ti:tputs ti:cursor-up))
73 (ti:tputs ti:column-address col))
74
75 (defmethod display ((backend smart-terminal) &key prompt line point markup)
76 (let* (;; SBCL and CMUCL traditionally point *terminal-io* to /dev/tty,
77 ;; and we do output on it assuming it goes to STDOUT. Binding
78 ;; *terminal-io* is unportable, so do it only when needed.
79 #+(or sbcl cmu)
80 (*terminal-io* *standard-output*)
81 (columns (backend-columns backend))
82 (old-markup (old-markup backend))
83 (old-point (old-point backend))
84 (old-col (find-col old-point columns))
85 (old-row (find-row old-point columns))
86 (old (old-string backend))
87 (new (concat prompt line))
88 (end (length new))
89 (rows (find-row end columns)))
90 (when (dirty-p backend)
91 (setf old-markup 0
92 old-point 0
93 old-col 0
94 old-row 1))
95 (multiple-value-bind (marked-line markup)
96 (if markup
97 (dwim-mark-parens line point
98 :pre-mark ti:enter-bold-mode
99 :post-mark ti:exit-attribute-mode)
100 (values line point))
101 (let* ((full (concat prompt marked-line))
102 (point (+ point (length prompt)))
103 (point-row (find-row point columns))
104 (point-col (find-col point columns))
105 (diff (mismatch new old))
106 (start (min* old-point point markup old-markup diff end))
107 (start-row (find-row start columns))
108 (start-col (find-col start columns)))
109 (dbg "---~%")
110 (dbg-values (subseq new start))
111 (dbg-values rows point point-row point-col start start-row start-col
112 old-point old-row old-col end diff)
113 (move-in-column
114 :col start-col
115 :vertical (- old-row start-row)
116 :clear-to-eos t
117 :current-col old-col)
118 (write-string (subseq full start))
119 (fix-wraparound start end columns)
120 (move-in-column
121 :col point-col
122 :vertical (- rows point-row)
123 :current-col (find-col end columns))
124 ;; Save state
125 (setf (old-string backend) new
126 (old-markup backend) markup
127 (old-point backend) point
128 (dirty-p backend) nil)))
129 (force-output *terminal-io*)))

  ViewVC Help
Powered by ViewVC 1.1.5