| LispmFPGA |
| LispmFPGA |
Home
Project Log
The code
Videos
Sample
The following is the basis of a simple text editor. It uses the CAPI functionality of Lispworks for providing a testbed for input/output functions. But it is modularized in a way, that the elementary input/output part can be easily transferred to other systems and made more efficient. Finally it will be the system editor of the LispmFPGA system.
The editor uses a concatenated list of lines as a data structure for the text body. Details become clear from the defstructs at the beginning of the code. The correct management of this list in cases of insertion and deletion is not absolutely trivial and was the major source of bugs during development.
The editor may still contain some bugs and some functionality is not implemented yet. Especially marking, cut, copy and efficient output is missing - currently on every output event the whole screen is redrawn. This is unacceptable in working code and must be remedied by adding a logic that keeps book about the structure of the minimal amount of redrawing necessary. This will often be just a cursor move or the redrawing of a single line.
(defstruct (point-2d (:conc-name pt2d-))
(x 0)
(y 0)
)
;;
;; Textmanager
;;
(defconstant +no-marking+ 0)
(defconstant +marking+ 1)
(defstruct (textmanager (:conc-name tm-))
(text (make-text))
(mark-state +no-marking+)
(caret (freeze-pt (get-point)))
(old-caret nil)
(mark-start (freeze-pt (get-point)))
(modif-start (freeze-pt (get-point)))
(modif-end (freeze-pt (get-point)))
(preferred-x 0)
move-code
)
;;
;; Window
;;
(defstruct (window (:conc-name win-))
(textm (make-textmanager))
(upper-left-pt (get-point))
(cursor (make-point-2d))
(cursor-old (make-point-2d))
)
;;
;; Point
;;
(defstruct (point (:conc-name pt-))
line
pos-in-line
frozen
)
;;
;; Line
;;
(defstruct (line
(:print-function
(lambda (obj str n)
(format str "#(Line :buffer ~a :len ~a :start-visible ~a :line-num ~a :mark-start ~a :mark-end ~a)"
(line-buffer obj) (line-len obj) (line-start-visible obj)
(line-line-num obj) (line-mark-start obj) (line-mark-end obj)))))
prev
next
buffer
len
start-visible
line-num
mark-start
mark-end
)
;;
;; Text
;;
(defstruct (text (:conc-name txt-))
first-line
last-line
num-lines)
;;
;; the move-codes
;;
(defconstant +up+ 0)
(defconstant +down+ 1)
(defconstant +left+ 2)
(defconstant +right+ 3)
(defconstant +pg-up+ 4)
(defconstant +pg-down+ 5)
(defconstant +home+ 6)
(defconstant +end+ 7)
;;
;; maximal length of buffer in a line
;;
(defparameter *max-line-len* 150)
;;
;; number of lines to scroll
;;
(defparameter *pg-down-cnt* 50)
(defparameter *pg-up-cnt* -50)
;;
;; screen height and width
;;
(defparameter *max-lines* 54)
(defparameter *max-cols* *max-line-len*)
;;
;; ascii-codes
;;
(defconstant +ascii-val-ret+ 13)
(defconstant +ret-char+ (code-char 13))
;;
;; the init-functions initialize already created structures
;;
(defun init-text (text)
(setf (txt-first-line text) nil)
(setf (txt-last-line text) nil)
(setf (txt-num-lines text) 0)
text)
(defun init-text-line (text line)
(setf (txt-first-line text) line)
(setf (txt-last-line text) line)
(setf (txt-num-lines text) 1)
text)
(defun init-textmanager (textm)
(setf (tm-text textm) (init-text (tm-text textm)))
(setf (tm-mark-state textm) +no-marking+)
(setf (tm-caret textm) (freeze-pt (get-point)))
(setf (tm-mark-start textm) (freeze-pt (get-point)))
textm)
(defun copy-to-buffer (buffer str n)
(do ((i 0 (+ i 1)))
((or (>= i n) (>= i *max-line-len*)))
(setf (char buffer i) (char str i))))
(defun init-line-string-n (line str n)
(setf (line-prev line) nil (line-next line) nil)
(setf (line-buffer line) (make-string *max-line-len*))
(copy-to-buffer (line-buffer line) str n)
(setf (line-len line) n)
(setf (line-start-visible line) (compute-start-visible line))
(setf (line-line-num line) 0)
(setf (line-mark-start line) 0)
(setf (line-mark-end line) 0)
line)
(defun init-line-string (line str)
(init-line-string-n line str (length str)))
(setf *global-str-buffer* (make-string *max-line-len*))
(defun init-line-ch (line ch)
(setf (char *global-str-buffer* 0) ch)
(init-line-string-n line *global-str-buffer* 1))
(defun compute-start-visible (line)
0)
;;
;; text functions
;;
(defun is-empty-text (text)
(and (null (txt-first-line text)) (null (txt-last-line text))))
;; updates pos-in-text in lines following pt
(defun update-line-num (pt)
(let ((akt-line (pt-line pt)))
(let ((akt-line-num (+ (line-line-num akt-line) 1)))
(do ((pline (line-next akt-line) (line-next pline)))
((null pline))
(setf (line-line-num pline) akt-line-num)
(setf akt-line-num (+ akt-line-num 1))))))
;; insert line after line pointed to by pt
(defun insert-in-text (text pt line)
(let ((pline (pt-line pt)))
(let ((follow (line-next pline)))
(setf (line-next pline) line)
(setf (line-prev line) pline)
(if follow
(progn
(setf (line-next line) follow)
(setf (line-prev follow) line))
(progn
(setf (txt-last-line text) line)))
(update-line-num pt))))
;;
;; inserts a character ch at pt, possibly moving text further down
;; if a is moved by inserting ch then a new line is created, otherwise inserting restarts at beginning
;; of next-line
;;
(defparameter *max-cols-eff* (- *max-cols* 5))
(defun line-buffer-full (line)
(= (line-len line) *max-line-len*))
(defun line-at-limit-p (pt)
(>= (xpos-disp (line-end pt)) *max-cols-eff*))
(defun line-ends-in-cr (line)
(eq (char (line-buffer line) (- (line-len line) 1)) +ret-char+))
(defun line-is-last-p (line)
(null (line-next line)))
(defun last-ch (line)
(char (line-buffer line) (- (line-len line) 1)))
(defun insert-in-line (pt ch offset)
(let* ((pline (pt-line pt))
(ipos (pt-pos-in-line pt))
(buffer (line-buffer pline)))
(do ((i (+ (line-len pline) offset) (- i 1)))
((<= i ipos))
(setf (char buffer i) (char buffer (- i 1))))
(setf (char buffer ipos) ch)
(setf (line-len pline) (+ (+ (line-len pline) 1) offset))))
(defun shorten-line (pt offset)
(let ((pline (pt-line pt)))
(setf (line-len pline) (- (line-len pline) offset))))
(defun insert-ch-at (text pt ch)
(let ((pline (pt-line pt)))
(freeze-pt pt)
(insert-in-line pt ch 0)
(do ()
((not (line-at-limit-p pt)))
(if (line-ends-in-cr pline)
(progn
(insert-in-text text pt
(init-line-ch (make-line) +ret-char+))
(shorten-line pt 1))
(let ((pt-next (line-down pt)))
(freeze-pt pt-next)
(if pt-next
(let ((cc (last-ch pline)))
(shorten-line pt 1)
(insert-ch-at text pt-next cc))
(let ((cc (last-ch pline)))
(insert-in-text text pt (init-line-ch (make-line) cc))
(shorten-line-pt pt 1)))
(thaw-pt pt-next))))
(thaw-pt pt)))
;;
;; the rebalancing routines keep the list of lines in a proper state
;; thereby also screen rendering is kept correct as given by the
;; rules of this editor
;;
(defun is-first-line (text pt)
(eq (pt-line pt) (txt-first-line text)))
(defun is-last-line (text pt)
(eq (pt-line pt) (txt-last-line text)))
;; cf = caret move allowed flag
(defun rebalance-empty-first-line (win textm text pt cf)
(if (is-last-line text pt)
(progn
(init-text text))
(let* ((pt1 (line-down pt))
(line1 (pt-line pt1)))
(setf (txt-first-line text) line1)
(setf (line-prev line1) nil)
(setf (line-line-num line1) 0)
(update-line-num pt1)
(setf (win-upper-left-pt win) pt1)
(if cf
(let ((old-caret nil))
(set-new-caret textm pt1 old-caret))))))
(defun rebalance-empty-last-line (win textm text pt cf)
(let* ((pt1 (line-up pt))
(line1 (pt-line pt1)))
(setf (txt-last-line text) line1)
(setf (line-next line1) nil)
(if cf
(let ((old-caret nil))
(set-new-caret textm (line-end pt1) old-caret)))))
(defun rebalance-empty-mid-line (win textm text pt cf)
(let ((pt1 (line-up pt))
(pt2 (line-down pt)))
(let ((line1 (pt-line pt1))
(line2 (pt-line pt2)))
(setf (line-next line1) line2)
(setf (line-prev line2) line1)
(update-line-num pt1)
(if cf
(let ((old-caret nil))
(set-new-caret textm (line-anf pt2) old-caret))))))
(defun rebalance-empty (win textm pt cf)
(let ((text (tm-text textm)))
(if (is-first-line text pt)
(rebalance-empty-first-line win textm text pt cf)
(if (is-last-line text pt)
(rebalance-empty-last-line win textm text pt cf)
(rebalance-empty-mid-line win textm text pt cf)))))
(defun rebalance-last-non-empty (win textm pt cf)
(if cf
(let ((pline (pt-line pt)))
(if (<= (line-len pline) (pt-pos-in-line pt))
(let ((pt (line-end pt))
(old-caret nil))
(set-new-caret textm pt old-caret))
(let ((old-caret (tm-caret textm)))
(set-new-caret textm pt old-caret))))))
(defun shift-line (line d)
(let ((buffer (line-buffer line))
(len (line-len line)))
(do ((i 0 (+ i 1))
(j d (+ j 1)))
((>= j len))
(setf (char buffer i) (char buffer j)))
(setf (line-len line) (- len d))))
(defun rebalance-move-1 (line line1)
(let ((buffer (line-buffer line))
(buffer1 (line-buffer line1))
(len (line-len line))
(len1 (line-len line1)))
(let ((last-xpos
(do ((i 0 (+ i 1))
(xpos 0 xpos))
((>= i len) xpos)
(setf xpos (next-xpos-ch xpos (char buffer i))))))
(do ((i len (+ i 1))
(j 0 (+ j 1))
(xpos last-xpos xpos))
((or (>= i *max-line-len*) (>= j len1) (>= xpos *max-cols-eff*))
(setf (line-len line) i)
(shift-line line1 j)
t)
(setf (char buffer i) (char buffer1 j))
(setf xpos (next-xpos-ch xpos (char buffer i)))))))
(defun rebalance-move (pt pt-next)
(let ((line (pt-line pt))
(line1 (pt-line pt-next)))
(if (line-ends-in-cr line)
nil
(rebalance-move-1 line line1))))
(defun rebalance (win textm pt cf)
(let ((pline (pt-line pt)))
(freeze-pt pt)
(if (= 0 (line-len pline))
(rebalance-empty win textm pt cf)
(let ((pt-next (line-down pt)))
(if pt-next
(progn
(if (rebalance-move pt pt-next)
(rebalance win textm pt-next nil))
(if cf
(let ((old-caret (tm-caret textm)))
(set-new-caret textm pt old-caret))))
(rebalance-last-non-empty win textm pt cf))))
(thaw-pt pt)))
;;
;; deletes a character at pt, possibly moving text further up by calling rebalance
;;
;;
(defun delete-in-line (pt)
(let* ((pline (pt-line pt))
(len (line-len pline)))
(let ((buffer (line-buffer pline)))
(do ((i (pt-pos-in-line pt) (+ i 1)))
((>= i len))
(setf (char buffer i) (char buffer (+ i 1))))
(setf (line-len pline) (- len 1)))))
(defun delete-ch-at (win textm pt)
(delete-in-line pt)
(rebalance win textm pt t))
;; insert a carriage return
(defun insert-cr-at (win textm pt)
(let* ((line (pt-line pt))
(line1 (init-line-ch (make-line) (char (line-buffer line) (pt-pos-in-line pt)))))
(let ((len (line-len line))
(buffer (line-buffer line))
(buffer1 (line-buffer line1)))
(insert-in-text (tm-text textm) pt line1)
(do ((i (+ (pt-pos-in-line pt) 1) (+ i 1))
(j 1 (+ j 1)))
((>= i len)
(setf (line-len line1) j)
(setf (line-len line) (+ (pt-pos-in-line pt) 1))
(setf (char buffer (pt-pos-in-line pt)) +ret-char+))
(setf (char buffer1 j) (char buffer i)))
(let ((pt1 (line-to-pt line1 0)))
(rebalance win textm pt1 nil)
(let ((old-caret nil))
(set-new-caret textm pt1 old-caret))))))
;;
;; appends a line to a text
;;
(setf *linecnt* 0)
(defun append-text-line (text line)
(if (is-empty-text text)
(init-text-line text line)
(progn
(insert-in-text text (line-to-pt (txt-last-line text) 0) line))))
;;
;;
;; textm functions
;;
;; appends a line to the text managed by textm
(defun append-textm-line (textm line)
(if (is-empty-text (tm-text textm))
(progn
(append-text-line (tm-text textm) line)
(thaw-pt (tm-caret textm))
(setf (tm-caret textm) (line-to-pt (txt-first-line (tm-text textm)) 0))
(freeze-pt (tm-caret textm)))
(append-text-line (tm-text textm) line)))
;; appends a line containing string to the text managed by textm
(defun append-textm-string (textm str)
(append-textm-line textm (init-line-string (make-line) str)))
;;
;; the edit window callback
;;
;;
(defun is-ascii-char (ch)
(and (numberp ch) (>= ch 32) (<= ch 126)))
(defun is-vk-down (ch)
(eq ch :down))
(defun is-vk-up (ch)
(eq ch :up))
(defun is-vk-left (ch)
(eq ch :left))
(defun is-vk-right (ch)
(eq ch :right))
(defun is-home (ch)
(eq ch :home))
(defun is-end (ch)
(eq ch :end))
(defun is-pg-up (ch)
(eq ch :prior))
(defun is-pg-down (ch)
(eq ch :next))
(defun is-delete (ch)
(and (numberp ch) (= ch 127)))
(defun is-carriage-return (ch)
(and (numberp ch) (= ch 13)))
(defun is-backspace (ch)
(and (numberp ch) (= ch 8)))
(defun callback-edit-window (win event ch modif)
(let ((textm (win-textm win)))
(cond ((is-ascii-char ch)
(win-insert-char win textm ch))
((is-vk-down ch)
(win-down win textm modif))
((is-vk-up ch)
(win-up win textm modif))
((is-vk-left ch)
(win-left win textm modif))
((is-vk-right ch)
(win-right win textm modif))
((is-home ch)
(win-home win textm modif))
((is-end ch)
(win-end win textm modif))
((is-pg-up ch)
(win-pg-up win textm modif))
((is-pg-down ch)
(win-pg-down win textm modif))
((is-delete ch)
(win-delete win textm))
((is-carriage-return ch)
(win-insert-cr win textm modif))
((is-backspace ch)
(win-backspace win textm modif))
((is-tab ch)
(win-insert-tab win textm modif)))
(update-display win textm)))
;;
;; addition of (x y) moves ul-pt on screen to akt-pt on screen
;;
(defun pt-to-x-y (ul-pt akt-pt)
(let ((line-ul (pt-line ul-pt))
(line-ap (pt-line akt-pt)))
(let ((ln-ul (line-line-num line-ul))
(ln-ap (line-line-num line-ap)))
(let ((y (- ln-ap ln-ul)))
(let ((x (- (xpos-disp akt-pt) (xpos-disp ul-pt))))
(values x y))))))
(defun y-to-pt (dy pt)
(let ((pt-1 pt)
(pt-old nil))
(do ()
((or (= dy 0) (null pt-1)) (if (null pt-1) pt-old pt-1))
(if (< dy 0)
(progn
(setf pt-old pt-1)
(setf pt-1 (line-up pt-1))
(setf dy (+ dy 1)))
(progn
(setf pt-old pt-1)
(setf pt-1 (line-down pt-1))
(setf dy (- dy 1)))))))
(defun update-display (win textm)
(let ((ulp-pt (win-upper-left-pt win)))
(if (tm-old-caret textm)
(multiple-value-bind (dx dy) (pt-to-x-y (tm-old-caret textm) (tm-caret textm))
(let ((cx (pt2d-x (win-cursor win)))
(cy (pt2d-y (win-cursor win))))
(let ((cy-new (+ cy dy))
(new-ulp-pt ulp-pt))
(if (or (< cy-new 0) (> cy-new (- *max-lines* 1)))
(progn
(setf new-ulp-pt (y-to-pt dy ulp-pt))
(multiple-value-bind (dx dy) (pt-to-x-y new-ulp-pt (tm-caret textm))
(setf (pt2d-x (win-cursor win)) dx)
(setf (pt2d-y (win-cursor win)) dy)))
(progn
(setf (pt2d-x (win-cursor win)) (+ cx dx))
(setf (pt2d-y (win-cursor win)) (+ cy dy))))
(if (point-eq new-ulp-pt ulp-pt)
(redisplay-select-part win textm)
(progn
(setf (win-upper-left-pt win) new-ulp-pt)
(redisplay-all win textm))))))
(multiple-value-bind (dx dy) (pt-to-x-y ulp-pt (tm-caret textm))
(setf (pt2d-x (win-cursor win)) dx)
(setf (pt2d-y (win-cursor win)) dy)
(if (or (< dy 0) (> dy (- *max-lines* 1)))
(let ((ddy
(if (> dy (- *max-lines* 1))
(- dy (- *max-lines* 1))
dy)))
(setf new-ulp-pt (y-to-pt ddy ulp-pt))
(multiple-value-bind (dx dy) (pt-to-x-y new-ulp-pt (tm-caret textm))
(setf (pt2d-x (win-cursor win)) dx)
(setf (pt2d-y (win-cursor win)) dy))
(setf (win-upper-left-pt win) new-ulp-pt)))
(setf (tm-old-caret textm) (tm-caret textm))
(redisplay-all win textm)))))
(defun redisplay-select-part (win textm)
(redisplay-all win textm))
(setf *cx-old* 0 *cy-old* 0)
(defun redisplay-all (win textm)
(setf *cx-old* *cx* *cy-old* *cy*)
(setf *cx* (pt2d-x (win-cursor win)))
(setf *cy* (pt2d-y (win-cursor win)))
(fill-buffer-from-pt (win-upper-left-pt win))
(redraw-terminal *terminal-pane* 0 0 1400 1200))
;;
;; the delegating move functions
;;
(defun win-right (win textm modif)
(textm-move textm modif +right+))
(defun win-left (win textm modif)
(textm-move textm modif +left+))
(defun win-up (win textm modif)
(textm-move textm modif +up+))
(defun win-down (win textm modif)
(textm-move textm modif +down+))
(defun win-pg-up (win textm modif)
(textm-move textm modif +pg-up+))
(defun win-pg-down (win textm modif)
(textm-move textm modif +pg-down+))
(defun win-home (win textm modif)
(textm-move textm modif +home+))
(defun win-end (win textm modif)
(textm-move textm modif +end+))
;;
;; the non delegating functions, operating on textm
;;
(defun set-new-caret (textm new-caret old-caret)
(thaw-pt (tm-old-caret textm))
(freeze-pt new-caret)
(setf (tm-old-caret textm) old-caret)
(setf (tm-caret textm) new-caret))
(defun win-insert-char (win textm ch)
(let ((old-caret (tm-caret textm))
(text (tm-text textm)))
(insert-ch-at text old-caret (code-char ch))
(let ((new-caret (get-new-caret textm +right+)))
(set-new-caret textm new-caret old-caret))))
(defun win-insert-tab (win textm modif)
)
(defun win-backspace (win textm modif)
(let ((caret-before (tm-caret textm))
(caret-after nil))
(win-left win textm modif)
(update-display win textm)
(setf caret-after (tm-caret textm))
(if (not (point-eq caret-before caret-after))
(win-delete win textm))))
(defun win-delete (win textm)
(let ((caret (tm-caret textm)))
(delete-ch-at win textm caret)))
(defun win-insert-cr (win textm modif)
(let ((caret (tm-caret textm)))
(insert-cr-at win textm caret)))
;;
;; the point functions
;;
;;
;;
;;
;; freeze-pt makes point pt persistent in pool
;; thaw-pt makes pt reclaimable in pool
;; not implemented yet
;;
(defun freeze-pt (pt)
pt)
(defun thaw-pt (pt)
pt)
;;
;; get-point allocates points from a pool
;; functionality not implemented yet
;;
(defun get-point ()
(make-point))
;;
;; (point-leq pt1 pt2) is true when pt1 <= pt2 in the text they point to
;;
(defun point-leq (pt1 pt2)
(let ((line-num-1 (line-line-num (pt-line pt1)))
(line-num-2 (line-line-num (pt-line pt2))))
(or (< line-num-1 line-num-2)
(and (= line-num-1 line-num-2) (<= (pt-pos-in-line pt1) (pt-pos-in-line pt2))))))
(defun point-eq (pt1 pt2)
(and (eq (pt-line pt1) (pt-line pt2)) (= (pt-pos-in-line pt1) (pt-pos-in-line pt2))))
;; a point copy
(defun point-copy (pt)
(let ((res (get-point)))
(setf (pt-line res) (pt-line pt))
(setf (pt-pos-in-line res) (pt-pos-in-line pt))
res))
;;
;; return points pointing to line begin / line end of of line pointed to by line pt
;;
(defun line-anf (pt)
(let ((res (point-copy pt)))
(setf (pt-pos-in-line res) 0)
res))
(defun line-end (pt)
(let ((res (point-copy pt))
(end-line-pos (- (line-len (pt-line pt)) 1)))
(setf (pt-pos-in-line res) end-line-pos)
res))
;;
;; is true wenn pt is in line pointed to by line-pt
;;
(defun in-line (pt line-pt)
(eq (pt-line pt) (pt-line line-pt)))
;; converts line to pt pointing to line
(defun line-to-pt (line xpos)
(if (null line)
nil
(progn
(let ((pt (get-point)))
(setf (pt-line pt) line)
(setf (pt-pos-in-line pt) xpos)
pt))))
;; moves pt one line up resp. one line down
(defun line-up (pt)
(line-to-pt (line-prev (pt-line pt)) 0))
(defun line-down (pt)
(line-to-pt (line-next (pt-line pt)) 0))
;; computes x displacement of pt in line pointed to by pt
(defun is-tab-char (ch)
(= (char-code ch) 9))
(defun xpos-disp (pt)
(let* ((line (pt-line pt))
(buffer (line-buffer line)))
(do ((i 0 (+ i 1))
(xpos 0 xpos))
((>= i (pt-pos-in-line pt)) xpos)
(setf xpos (next-xpos-ch xpos (char buffer i))))))
(defun next-xpos-ch (xpos ch)
(if (is-tab-char ch)
(align (+ xpos 1) 4)
(+ xpos 1)))
(defun align (x n)
(if (= (mod x n) 0)
x
(* (+ (floor x n) 1) n)))
;;
;; returns moved point
;;
(defun move-point (pt move-code preferred-x)
(let ((line (pt-line pt))
(pt1 nil))
(cond ((= move-code +up+)
(setf pt1 (line-up pt))
(if pt1
(progn
(multiple-value-bind (pt real-x) (to-preferred-x pt1 preferred-x)
(setf pt1 pt)))
(progn
(setf pt1 pt))))
((= move-code +down+)
(setf pt1 (line-down pt))
(if pt1
(progn
(multiple-value-bind (pt real-x) (to-preferred-x pt1 preferred-x)
(setf pt1 pt)))
(progn
(setf pt1 pt))))
((= move-code +left+)
(if (at-beginning-of-line pt)
(let ((lup-pt (line-up pt)))
(if lup-pt
(progn
(setf pt1 (line-end lup-pt))
(setf preferred-x (xpos-disp pt1)))
(setf pt1 pt)))
(progn
(setf pt1 (point-copy pt))
(setf pt1 (n-one-char-back pt1))
(setf preferred-x (xpos-disp pt1)))))
((= move-code +right+)
(if (at-end-of-line pt)
(let ((ld-pt (line-down pt)))
(if ld-pt
(progn
(setf pt1 (line-anf ld-pt))
(setf preferred-x (xpos-disp pt1)))
(setf pt1 pt)))
(progn
(setf pt1 (point-copy pt))
(setf pt1 (n-one-char-forward pt1))
(setf preferred-x (xpos-disp pt1)))))
((= move-code +pg-up+)
(setf pt1 (y-to-pt *pg-up-cnt* pt))
(multiple-value-bind (pt real-x) (to-preferred-x pt1 preferred-x)
(setf pt1 pt)))
((= move-code +pg-down+)
(setf pt1 (y-to-pt *pg-down-cnt* pt))
(multiple-value-bind (pt real-x) (to-preferred-x pt1 preferred-x)
(setf pt1 pt)))
((= move-code +home+)
(setf pt1 (line-anf pt))
(setf preferred-x 0))
((= move-code +end+)
(setf pt1 (line-end pt))
(setf preferred-x (xpos-disp pt1))))
(values pt1 preferred-x)))
(defun to-preferred-x (pt pref-x)
(let ((buffer (line-buffer (pt-line pt)))
(xpos 0)
(xpos-old nil)
(ll (line-len (pt-line pt))))
(let ((ipos
(do ((i 0 (+ i 1)))
((or (> xpos pref-x) (>= i ll)) i)
(setf xpos-old xpos)
(setf xpos (next-xpos-ch xpos (char buffer i))))))
(let ((pt-1 (point-copy pt)))
(setf (pt-pos-in-line pt-1) (- ipos 1))
(values pt-1 xpos-old)))))
(defun at-beginning-of-line (pt)
(= (pt-pos-in-line pt) 0))
(defun at-end-of-line (pt)
(= (pt-pos-in-line pt) (- (line-len (pt-line pt)) 1)))
(defun n-one-char-back (pt)
(setf (pt-pos-in-line pt) (- (pt-pos-in-line pt) 1))
pt)
(defun n-one-char-forward (pt)
(setf (pt-pos-in-line pt) (+ (pt-pos-in-line pt) 1))
pt)
(defun get-new-caret (textm move-code)
(multiple-value-bind (new-pt pref-x)
(move-point (tm-caret textm) move-code (tm-preferred-x textm))
(setf (tm-preferred-x textm) pref-x)
new-pt))
;;
;; extends the marked area when caret moves from old-pt to new-pt
;;
(defun extend-mark (textm old-pt new-pt)
;; two flags describing directions
(let ((move-caret-up (point-leq new-pt old-pt))
(akt-line-pt (line-anf new-pt))
(akt-pt (point-copy old-pt)))
;; go through full lines lying between old-pt and new-pt
(freeze-pt akt-line-pt)
(do ((next-akt-pt nil next-akt-pt))
((in-line akt-pt akt-line-pt))
(if move-caret-up
(setf next-akt-pt (line-anf akt-pt))
(setf next-akt-pt (line-end akt-pt)))
(reverse-mark move-caret-up akt-pt next-akt-pt)
;; move-caret-up = t informs reverse-mark that next-akt-pt <= akt-pt
(if move-caret-up
(setf akt-pt (move-point next-akt-pt +left+ -1))
(setf akt-pt (move-point next-akt-pt +right+ -1))))
(thaw-pt akt-line-pt)
(reverse-mark move-caret-up akt-pt new-pt)))
;;
;;
;; the caret move only function, parameterized by move-code
;;
(defun shift-pressed-p (modif)
(= 1 (logand modif 1)))
(defun is-state (textm code)
(= (tm-mark-state textm) code))
(defun textm-move (textm modif move-code)
(let* ((old-caret (tm-caret textm))
(new-caret (get-new-caret textm move-code)))
(cond ((shift-pressed-p modif)
(cond ((is-state textm +marking+)
(extend-mark textm old-caret new-caret))
(t
(create-mark textm old-caret new-caret))))
(t
(cond ((is-state textm +marking+)
(clear-mark textm)))))
(set-new-caret textm new-caret old-caret)
(setf (tm-move-code textm) move-code)))
;;
;; the test output pane as a CAPI pane
;;
;;
;;
(defun terminal-input (self x y gspec)
(let ((data (sys:gesture-spec-data gspec))
(mods (sys:gesture-spec-modifiers gspec)))
; (gp:draw-string
; self
; (format nil "data = ~a mods = ~a~%" (numberp data) mods)
; (with-output-to-string (ss)
; (sys:print-pretty-gesture-spec
; gspec ss :force-shift-for-upcase nil))
; x y)
(callback-edit-window *test-win* 1 data mods)
))
(defclass terminal-pane (capi:output-pane)
()
(:default-initargs
:input-model '((:gesture-spec
terminal-input))
:display-callback 'redraw-terminal))
(setf *terminal-buffer* (make-array (list *max-lines* *max-cols*) :initial-element #\Space ))
(setf *test-win* (make-window))
(defun init-win (win fname)
(setf *cx* 0)
(setf *cy* 0)
(setf (win-textm win) (init-textmanager (win-textm win)))
(with-open-file (str fname :direction :input)
(loop
with line-str = nil
do
(setf line-str (read-line str nil nil nil))
(when line-str
(append-textm-string (win-textm win) (concatenate 'string line-str (string #\Return))))
until (null line-str))
(setf (tm-caret (win-textm win)) (line-to-pt (txt-first-line (tm-text (win-textm win))) 0))
(setf (tm-old-caret (win-textm win)) (line-to-pt (txt-first-line (tm-text (win-textm win))) 0))
(setf (win-upper-left-pt win) (line-to-pt (txt-first-line (tm-text (win-textm win))) 0))
; (setf (win-cursor win) (tm-caret (win-textm win)))
(freeze-pt (win-cursor win))
(freeze-pt (win-upper-left-pt win))))
(defun fill-buffer-from-pt (pt)
(let ((lasti
(loop
for i from 0 to (1- *max-lines*) do
(fill-buffer-pt i pt)
(setf pt (line-down pt))
until (null pt)
finally return (if (null pt) (+ i 1) i))))
(loop
for i from lasti to (1- *max-lines*) do
(loop
for j from 0 to (1- *max-cols*) do
(setf (aref *terminal-buffer* i j) #\Space)))))
(defun fill-buffer-pt (i pt)
(let ((line (pt-line pt)))
(let ((jj (min (1- (line-len line)) (1- *max-cols*))))
(let ((xpos-end
(loop
with xpos = 0
with xpos1 = nil
with cc = nil
for j from 0 to jj do
(setf cc (char (line-buffer line) j))
(setf (aref *terminal-buffer* i xpos) cc)
(setf xpos1 (next-xpos-ch xpos cc))
(loop for j1 from (+ xpos 1) to (- xpos1 1) do
(setf (aref *terminal-buffer* i j1) #\.))
(setf xpos xpos1)
finally return xpos)))
(loop
for j from xpos-end to (1- *max-cols*) do
(setf (aref *terminal-buffer* i j) #\Space))))))
(defconstant +yb+ 13)
(defconstant +xb+ 7)
(defun redraw-terminal (pane x y width height)
(let ((t-font (gp:find-best-font *terminal-pane* (gp:make-font-description :family "lucidatypewriter" :size 12)))
(color-cursor (color:make-rgb 1.0 0.0 0.0)))
(gp:set-graphics-state pane :font t-font :background :white)
(loop for i from 0 to (1- *max-lines*) do
(loop
for j from 0 to (1- *max-cols*) do
(let* ((cflag (and (= i *cy*) (= j *cx*)))
(cc (aref *terminal-buffer* i j)))
(if (< (char-code cc) 32)
(setf cc #\Space))
(if cflag
(gp:draw-character pane cc (* j +xb+) (+ (* i +yb+) +yb+)
:block t :background color-cursor)
(gp:draw-character pane cc (* j +xb+) (+ (* i +yb+) +yb+)
:block t)))))))
(defun showit ()
(init-win *test-win* "lispm-editor.lisp")
; (init-win *test-win* "testfile")
(fill-buffer-from-pt (line-to-pt (txt-first-line (tm-text (win-textm *test-win*))) 0))
(setf *terminal-pane* (capi:contain (make-instance 'terminal-pane :title "Terminal"))))
(defun displayit ()
(loop
with pline = (txt-first-line (tm-text (win-textm *test-win*)))
do
(format t "~a ~a ~a~%" (line-line-num pline) (line-len pline) (subseq (line-buffer pline) 0 (line-len pline)))
(setf pline (line-next pline))
until (null pline)))
(defun ntabs (n)
(let ((s (make-string n)))
(loop for i from 0 to (1- n) do (setf (char s i) #\Tab))
s))
(setf *str* (concatenate 'string (ntabs 3) "wuerfel und kugel" (ntabs 2) "kreis und kegel"))
(setf *testline* (make-line))
(init-line-string *testline* *str*)
(setf *pt* (line-to-pt *testline* 0))
Zuletzt geändert - 17 02 2008