;; The beginning...
;;
;; 
;;Global functions
;;
;;move x-from y-from w h x-to y-to
;;
;;allgemeine move-routine für text-blöcke
;;
;;
;;Global Objects
;;
;;Cursor sys-cursor
;;
;;
;;
;;
;;
;;
;;Objects
;;
;;Cursor
;;
;;int xpos ypos xpos-mem ypos-mem
;;
;;move-down max-y
;;move-up min-y
;;move-left min-x
;;move-right max-x
;;
;;
;;
;;Window 
;;======
;;int x y w h
;;
;;(x y) Koordinaten obere linke Ecke
;;(w h) Width Height
;;
;;
;;
;;WindowWithCursor
;;================
;;Window
;;Cursor
;;
;;
;;TextWindow
;;==========
;;Window
;;Cursor
;;Text text
;;Point cursor-point
;;(Point) aux-point-list
;;
;;Text
;;====
;;(Line) lines
;;int num-lines
;;
;;
;;
;;Line
;;====
;;String text
;;int line-len
;;int left-start
;;
;;;; for managing marked parts of text
;;int mark-start
;;int mark-end
;;

;;Point
;;=====
;;pointer into (Line) of Text: line 
;;int pos  ;; 0 <= pos <= (line-len line)
;;int pos-cnt
;;
;;move-up
;;move-down
;;
;;move-left
;;move-right
;;
;;insert-at char c
;;insert-at string str
;;
;;break-line-at
;;
;;copy
;;
;;
;;
;;Window  <-------> WindowClass
;;
;;Window ------> WindowClassFunction 
;;    IndividualWindowData
;;
;;WindowClassFunction receives WindowHandle = Window as a lisp pointer as parameter
;;thereby gets access to individual Window Data
;;
;;Example
;;
;;TextWindow
;;
;;| WindowWithCursor | text | cursor-point | aux-point-list |
;;
;;
;;An Event is a structure of
;;
;;|event|ch|modif|
;;
;;integer event
;;ch and modif general lisp pointers
;;
;;for key events
;;ch and modif have the function explicated in *keyb01*
;;
;;event = 1: key press event
;;event = 2: key release event
;;
;;
;;
;;Edit Window
;; |      |
;; |      |
;; |      |
;; |   Display Control   
;; |      |
;; |   ___/
;; |  /
;; | |
;;Text
;;
;;

(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)

(defconstant +insert+ 10)
(defconstant +delete+ 11)
(defconstant +insert-cr+ 12)


;;
;; maximal length of buffer in a line
;;

(defparameter *max-line-len* 100)

;;
;; number of lines to scroll
;;

(defparameter *pg-down-cnt* 50)
(defparameter *pg-up-cnt* -50)

;;
;; screen height and width
;;

(defparameter *max-lines* 35)
(defparameter *max-cols* *max-line-len*)


;;
;; ascii-codes
;;

(defconstant +ascii-val-ret+ 13)
(defconstant +ret-char+ (code-char 13))

;;
;; setting on condition of being nil modif-start and modif-end
;;

(defun set-modif-start (textm pt)
  (if (null (tm-modif-start textm))
      (setf (tm-modif-start textm) pt)))


(defun set-modif-end (textm pt)
  (if (null (tm-modif-end textm))
      (setf (tm-modif-end textm) pt)))



;;
;; 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 <cr> 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 (textm pt ch)
  (let ((text (tm-text textm)))
    (let ((pline (pt-line pt)))
      (set-modif-start textm 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 textm 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))))
      (if (or (line-ends-in-cr (pt-line pt)) (is-last-line text pt))
          (set-modif-end textm (line-end pt)))
      (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)
      (set-modif-start textm 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)
    (set-modif-start textm pt1)
    (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)
      (set-modif-start textm pt2)
      (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-modif-start textm pt)
              (set-modif-end textm pt)
              (set-new-caret textm pt old-caret))
          (let ((old-caret (tm-caret textm)))
            (set-modif-start textm pt)
            (set-modif-end textm (line-end pt))
            (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 (textm pt pt-next)
  (let ((line (pt-line pt))
        (line1 (pt-line pt-next)))
    (if (line-ends-in-cr line)
        (let ()
          (set-modif-start textm pt)
          (set-modif-end textm (line-end pt))
          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)))
        (set-modif-start textm pt)
        (if pt-next
            (progn
              (if (rebalance-move textm 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)
  (setf (tm-modif-start textm) nil)
  (setf (tm-modif-end textm) nil)
  (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)))
        (setf (tm-modif-start textm) pt)
        (setf (tm-modif-end textm) nil)
        (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-modif-part (win textm)
  (setf *cx-old* *cx* *cy-old* *cy*)
  (setf *cx* (pt2d-x (win-cursor win)))
  (setf *cy* (pt2d-y (win-cursor win)))
  (draw-between-points *terminal-pane* win textm (tm-modif-start textm) (tm-modif-end textm)))
  


(defun redisplay-moved-cursor (win textm)
  (setf *cx-old* *cx* *cy-old* *cy*)
  (setf *cx* (pt2d-x (win-cursor win)))
  (setf *cy* (pt2d-y (win-cursor win)))
  (draw-single-pt *terminal-pane* *cx-old* *cy-old*)
  (draw-single-pt *terminal-pane* *cx* *cy*))
  

(defun redisplay-select-part (win textm)
  (if (member (tm-move-code textm) (list +up+ +down+ +left+ +right+ +home+ +end+ +pg-up+ +pg-down+))
      (redisplay-moved-cursor win textm)
    (if (member (tm-move-code textm) (list +delete+ +insert-cr+ +insert+))
        (redisplay-modif-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)))
    (setf (tm-move-code textm) +insert+)
    (setf (tm-modif-start textm) nil)
    (setf (tm-modif-end textm) nil)
    (insert-ch-at textm 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)))
    (setf (tm-move-code textm) +delete+)
    (delete-ch-at win textm caret)))




(defun win-insert-cr (win textm modif)
  (let ((caret (tm-caret textm)))
    (setf (tm-move-code textm) +insert-cr+)
    (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))
     (setf line-str (subseq line-str 0 (min (length line-str) (- *max-line-len* 3))))
     (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))))))
          
(defun fill-buffer-pt-1 (i pt)
  (let ((line (pt-line pt)))
    (let ((jj (min (1- (line-len line)) (1- *max-cols*)))) 
      (let ((xpos-end 
             (loop
              with xpos = (xpos-disp pt)
              with xpos1 = nil
              with cc = nil
              with j0 = (pt-pos-in-line pt)
              for j from j0 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 draw-line-rest (pane x y)

  (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 j from x to (1- *max-cols*) do
     (let* ((cflag (and (= y *cy*) (= j *cx*)))
            (cc (aref *terminal-buffer* y j)))
       (if (< (char-code cc) 32)
           (setf cc #\Space))
       (if cflag
           (gp:draw-character pane cc (* j +xb+) (+ (* y +yb+) +yb+)
                              :block t :background color-cursor)
         (gp:draw-character pane cc (* j +xb+) (+ (* y +yb+) +yb+)
                            :block t))))))
                 
(defun draw-single-pt (pane dx dy)
   (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)
     (let* ((cflag (and (= dy *cy*) (= dx *cx*)))
            (cc (aref *terminal-buffer* dy dx)))
       (if (< (char-code cc) 32)
           (setf cc #\Space))
       (if cflag
           (gp:draw-character pane cc (* dx +xb+) (+ (* dy +yb+) +yb+)
                              :block t :background color-cursor)
         (gp:draw-character pane cc (* dx +xb+) (+ (* dy +yb+) +yb+)
                            :block t)))))
     
 
(defun draw-between-points (pane win textm pt1 pt2)
  (let ((ulp-pt (win-upper-left-pt win)))
    (multiple-value-bind (x1 y1) (pt-to-x-y ulp-pt pt1)
      (let ((x2 nil)
            (y2 nil))
        (if pt2
          (multiple-value-bind (x y) (pt-to-x-y ulp-pt pt2)
            (setf x2 x)
            (setf y2 y)))
        (do ()
            ((or (null pt1) (>= y1 *max-lines*) (and y2 (> y1 y2))))
          (let* ((pline (pt-line pt1)))
            (fill-buffer-pt-1 y1 pt1)
            (draw-line-rest pane (xpos-disp pt1) y1)
            (setf pt1 (line-down pt1))
            (setf y1 (+ y1 1))))))))
          
                          
    

(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))