;; 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
;;
;;

(setf *editor01*

'(

(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
            (:conc-name 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
;;

(setf *max-line-len* 100)

;;
;; number of lines to scroll
;;

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

;;
;; screen height and width
;;

(setf *max-lines* 35)
(setf *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 
;;

(setf *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)))
      (setf (tm-preferred-x textm) 0)
      (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)))

    (if (%= event 16)
        (let () 

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

          (setf *inst2* (get-info 0))
          
          (update-display win textm)
          
          (setf *inst3* (get-info 0))

          (%print 11111)
          (%print (%- *inst3* *inst2*))


))))


;;
;; 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))
      (%print 700)
      (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 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*)

  (draw-cursor-at *cx-old* *cy-old* 0)
  (draw-cursor-at *cx* *cy* 1))
  

(defun is-move-code (code)
  (or (%= code +up+)
      (%= code +down+)
      (%= code +left+)
      (%= code +right+)
      (%= code +home+)
      (%= code +end+)
      (%= code +pg-up+)
      (%= code +pg-down+)))

(defun is-modify-code (code)
  (or (%= code +delete)
      (%= code +insert-cr+)
      (%= code +insert+)))

(defun redisplay-select-part (win textm)
;;  (redisplay-all win textm))

  (if (is-move-code (tm-move-code textm))
     (redisplay-moved-cursor win textm)
    (if (is-modify-code (tm-move-code textm))
        (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)))

  (setf *inst4* (get-info 0))
  (fill-buffer-from-pt (win-upper-left-pt win))

  (setf *inst5* (get-info 0))
  (%print 1111)
  (%print (%- *inst5* *inst4*)))

;;  (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)
  (%print 2222)
  (textm-move textm modif +pg-up+))


(defun win-pg-down (win textm modif)
  (%print 2223)
  (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) 2)
    (%+ 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+)
           (%print 1250)
           (setf pt1 (y-to-pt *pg-down-cnt* pt))
           (%print 1251)
           (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 (addr-and 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)))



;;
;; initialize window win with a text consisting of a single line containing a <cr>
;; 
									
(defun init-win (win)
  (setf *cx* 0)
  (setf *cy* 0)
  (setf (win-textm win) (init-textmanager (win-textm win)))
  (let ((line-str " "))
    (set-char line-str 0 (code-char 13))

    (append-textm-string (win-textm win) 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))

    (freeze-pt (win-cursor win))
    (freeze-pt (win-upper-left-pt win))))
									
				

;;
;; the following two functions work for output on the Spartan card or the simemu, but are very slow
;; for reasonable working need 50 Mhz system clock
;;

(defun fill-buffer-from-pt (pt)
  (let ((pline (pt-line pt))
        (p-vga 0))
    (let ((lasti
           (do ((i 0 (%+ i 1)))
               ((or (null pline) (%>= i *max-lines*))
                i)
             (let ((buffer (line-buffer pline))
                   (len (line-len pline)))
               (let ((lastj
                      (do ((j 0 (%+ j 1)))
                          ((%>= j len) j)
                        (set-byte base_vga p-vga (get-byte buffer (%+ j 8)))
                        (setf p-vga (%+ p-vga 4)))))
                 (setf pline (line-next pline))
                 (do ((j1 lastj (%+ j1 1)))
                     ((%>= j1 100)) ;; 100 = *max-cols*
                   (set-byte base_vga p-vga 32)
                   (setf p-vga (%+ p-vga 4)))
                 (setf p-vga (%+ p-vga 132)))))))
      (do ((i lasti (%+ i 1)))
          ((%>= i 35))
        (do ((j 0 (%+ j 1)))
            ((%>= j 100))
          (set-byte base_vga p-vga 32)
          (setf p-vga (%+ p-vga 4)))
        (setf p-vga (%+ p-vga 132)))
      (set-byte base_vga (%+ (%* (%+ *cx-old* (%* *cy-old* 133)) 4) 1) 0)
      (set-byte base_vga (%+ (%* (%+ *cx* (%* *cy* 133)) 4) 1) 1))))



;;;; (defun fill-buffer-from-pt (pt)
;;;;   (let ((pline (pt-line pt))
;;;;         (p-vga 0)
;;;;         (i 0)
;;;;         (j 0)
;;;;         (buffer nil)
;;;;         (len 0))
;;;;     (do-until
;;;;      ((or (null pline) (%>= i *max-lines*)))
;;;;      (setf buffer (line-buffer pline))
;;;;      (setf len (line-len pline))
;;;;      (do-until
;;;;       ((%>= j len))
;;;;       (set-byte base_vga p-vga (get-byte buffer (%+ j 8)))
;;;;       (setf j (%+ j 1))
;;;;       (setf p-vga (%+ p-vga 4)))
;;;;      (setf pline (line-next pline))
;;;;      (do-until
;;;;       ((%>= j 100))
;;;;       (set-byte base_vga p-vga 32)
;;;;       (setf p-vga (%+ p-vga 4))
;;;;       (setf j (%+ j 1)))
;;;;      (setf i (%+ i 1))
;;;;      (setf j 0)
;;;;      (setf p-vga (%+ p-vga 132)))
;;;;     (do-until
;;;;      ((%>= i 35))
;;;;      (setf j 0)
;;;;      (do-until
;;;;       ((%>= j 100))
;;;;       (set-byte base_vga p-vga 32)
;;;;       (setf p-vga (%+ p-vga 4))
;;;;       (setf j (%+ j 1)))
;;;;      (setf p-vga (%+ p-vga 132))
;;;;      (setf i (%+ i 1)))
;;;;     
;;;;     (set-byte base_vga (%+ (%* (%+ *cx-old* (%* *cy-old* 133)) 4) 1) 0)
;;;;     (set-byte base_vga (%+ (%* (%+ *cx* (%* *cy* 133)) 4) 1) 1)))







;;;; (defun fill-buffer-from-pt (pt)
;;;;   (let ((lasti
;;;;          (do ((i 0 (%+ i 1)))
;;;;              ((or (null pt) (%>= i *max-lines*))
;;;;               (if (null pt) i i))
;;;;            (fill-buffer-pt i pt)
;;;;            (setq pt (line-down pt)))))
;;;;     (do ((i lasti (%+ i 1)))
;;;;         ((%>= i *max-lines*))
;;;;       (do ((j 0 (%+ j 1)))
;;;;           ((%>= j *max-cols*))
;;;;         (screen-out j i 32)))))


;;;;    
;;;; (defun fill-buffer-pt (i pt)
;;;;   (let ((line (pt-line pt)))
;;;;     (let ((jj (min (%- (line-len line) 1) (%- *max-cols* 1)))) 
;;;;       (let ((xpos-end
;;;;              (let ((xpos 0)
;;;;                    (xpos1 nil)
;;;;                    (cc nil))
;;;;                (do ((j 0 (%+ j 1)))
;;;;                    ((%> j jj)
;;;;                     xpos)
;;;;                  (setq cc (char (line-buffer line) j))
;;;;                  (screen-out xpos i (char-code cc))
;;;;                  (setq xpos1 (next-xpos-ch xpos cc))
;;;;                  (do ((j1 (%+ xpos 1) (%+ j1 1)))
;;;;                      ((%> j1 (%- xpos1 1)))
;;;;                    (screen-out j1 i 32))
;;;;                  (setf xpos xpos1)))))
;;;;         (do ((j xpos-end (%+ j 1)))
;;;;             ((%>= j *max-cols*))
;;;;           (screen-out j i 32))))))

   
(defun fill-buffer-pt-1 (i pt)
  (let ((line (pt-line pt)))
    (let ((jj (min (%- (line-len line) 1) (%- *max-cols* 1)))) 
      (let ((xpos-end 
             (let ((xpos (xpos-disp pt))
                   (xpos1 nil)
                   (cc nil))
               (do ((j (pt-pos-in-line pt) (%+ j 1)))
                   ((%> j jj)
                    xpos)
                 (setq cc (char (line-buffer line) j))
                 (screen-out xpos i (char-code cc))
                 (setq xpos1 (next-xpos-ch xpos cc))
                 (do ((j1 (%+ xpos 1) (%+ j1 1)))
                     ((%> j1 (%- xpos1 1)))
                   (screen-out j1 i 32))
                 (setf xpos xpos1)))))
        (do ((j xpos-end (%+ j 1)))
            ((%>= j *max-cols*))
          (screen-out j i 32))))))


(defun screen-out (x y cc)
  (let ((p (%* (%+ x (%* y 133)) 4)))
    (set-byte base_vga p cc)
    (set-byte base_vga (%+ p 1) (if (and (%= x *cx*) (%= y *cy*)) 1 0))))


;;;;           
;;;; (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-cursor-at (dx dy val)
  (set-byte base_vga (%+ (%* 4 (%+ dx (%* dy 133))) 1) val))


;;;; (defun draw-between-points (pane win textm pt1 pt2)

(defun draw-between-points (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))

))