mcl-render.lisp

   1 (in-package "LICE")
   2
   3 (defclass mcl-window (ccl:window)
   4   ())
   5
   6 (defclass mcl-frame (frame mcl-window)
   7   ((double-buffer :type (array character 1) :initarg :double-buffer :accessor frame-double-buffer :documentation
   8                   "The display double buffer. This structure is compared to
   9 the characters we want to blit. Only differences are sent to the video
  10 hardware.")
  11    (2d-double-buffer :type (array character 2) :initarg :2d-double-buffer :accessor frame-2d-double-buffer :documentation
  12                      "Displaced from DISPLAY. This array is divided into rows and columns.")
  13    (cursor :initform #(0 0) :accessor mcl-frame-cursor)
  14    (font-width :initarg :font-width :accessor mcl-frame-font-width)
  15    (font-height :initarg :font-height :accessor mcl-frame-font-height)
  16    (font-ascent :initarg :font-ascent :accessor mcl-frame-font-ascent)))
  17
  18 (defmethod frame-start-render ((frame mcl-frame))
  19   (declare (ignore frame))
  20   )
  21
  22 (defmethod frame-end-render ((frame mcl-frame))
  23   (declare (ignore frame))
  24   (ccl:event-dispatch))
  25
  26
  27 (defun window-move-cursor (window x y)
  28   (declare (ignore window x y))
  29   )
  30
  31 (defmethod frame-move-cursor ((frame mcl-frame) win x y)
  32 ;;  (setf x (* x (mcl-frame-font-width frame))
  33 ;;        y (+ (* y (mcl-frame-font-height frame)) 10))
  34 ;;   (ccl:invert-rect frame x y (+ x (mcl-frame-font-width frame)) (+ y (mcl-frame-font-height frame)))
  35   (setf (mcl-frame-cursor frame) (vector (+ (window-x win) x) (+ (window-y win) y)))
  36   (window-move-cursor win x y))
  37
  38 (defun putch (ch x y window frame)
  39   ;; (0,0) is above the visible area of the window. so add 25 (experimentally determined).
  40 ;;  (setf x (* x (mcl-frame-font-width frame))
  41 ;;        y (+ (* y (mcl-frame-font-height frame)) 10))
  42 ;;  (ccl:move-to (mcl-frame-window frame) x y)
  43 ;;  (princ ch (mcl-frame-window frame))
  44   (setf (aref (frame-2d-double-buffer frame) (+ y (window-y window)) (+ (window-x window) x)) ch)
  45  )
  46
  47 (defun putstr (s x y w frame)
  48   (loop for i from 0 below (length s)
  49         for j from x by 1
  50         ;;if (char/= (aref (window-2d-display w) y j) (aref s i))
  51         do (putch (char s i) j y w frame)))
  52
  53 (defun clear-line-between (w y start end frame)
  54   "insert LEN spaces from START on line Y."
  55   (window-move-cursor w start y)
  56   ;; FIXME: this could be done faster
  57   (loop for i from start to end
  58         do (putch #\Space i y w frame)))
  59
  60 (defun clear-to-eol (y start window frame)
  61   (declare (type window window)
  62            (type fixnum y start))
  63 ;;   (let ((display (frame-2d-double-buffer frame))
  64 ;;      (linear (frame-double-buffer frame)))
  65     (clear-line-between window y start (1- (window-width window)) frame)
  66     ;; draw the seperator
  67     (when (window-seperator window)
  68       (putch #\| (+ (window-x window) (1- (window-width window t))) y window frame)))
  69
  70 (defun turn-on-attributes (buffer point)
  71   (declare (ignore buffer point))
  72   )
  73
  74 (defmethod frame-end-render ((frame mcl-frame))
  75   (ccl:invalidate-view frame))
  76
  77 (defmethod window-render (w (frame mcl-frame))
  78   "Render a window."
  79   ;; clear the window
  80   ;; (ccl:with-fore-color ccl:*white-color*
  81 ;;     (ccl:paint-rect (mcl-frame-window frame)  0 0
  82 ;;                     (ccl:point-h (ccl:view-size (mcl-frame-window frame)))
  83 ;;                     (ccl:point-v (ccl:view-size (mcl-frame-window frame))))
  84 ;;     (ccl:event-dispatch))
  85   (let ((p (buffer-char-to-aref (window-buffer w) (marker-position (window-top w))))
  86         ;; current point in buffer buffer
  87         (bp (marker-position (window-top w)))
  88         (buf (window-buffer w))
  89         ;; The cursor point in the buffer. When the buffer isn't
  90         ;; current, then use the window's backup of the point.
  91         (point (window-point w))
  92         cursor-x
  93         cursor-y
  94         (cache-size (length (lc-cache (window-cache w))))
  95         (linear (frame-double-buffer frame))
  96         (display (frame-2d-double-buffer frame)))
  97     (declare (ignore display linear))
  98     ;; clear the window
  99 ;;     (ccl:erase-rect (mcl-frame-window frame) 0 0
 100 ;;                     (ccl:point-h (ccl:view-size (mcl-frame-window frame)))
 101 ;;                     (ccl:point-v (ccl:view-size (mcl-frame-window frame))))
 102     ;; Special case: when the buffer is empty
 103     (if (= (buffer-size (window-buffer w)) 0)
 104         (progn
 105           (dotimes (y (window-height w))
 106             (clear-to-eol y 0 w frame))
 107           (setf cursor-x 0
 108                 cursor-y 0))
 109       (let ((end (loop named row
 110                        for y below (window-height w)
 111                        for line from (window-top-line w) below cache-size
 112                        ;; return the last line, so we can erase the rest
 113                        finally (return-from row y)
 114                        ;; go to the next line
 115                        do (let* ((line-end (cache-item-end (item-in-cache w line)))
 116                                  (line-start (cache-item-start (item-in-cache w line)))
 117                                  (next-prop (next-single-property-change line-start :face (window-buffer w) line-end)))
 118                             (setf bp (cache-item-start (item-in-cache w line))
 119                                   p (buffer-char-to-aref (window-buffer w) bp))
 120                             ;; setup the display properties.
 121                             (turn-on-attributes (window-buffer w) bp)
 122                             (loop named col
 123                                 for x below (window-width w) do
 124                                 (progn
 125                                   ;; Skip the gap
 126                                   (when (= p (buffer-gap-start buf))
 127                                     (incf p (buffer-gap-size buf)))
 128                                   ;; Record point position on screen
 129                                   (when (eq bp point)
 130                                     (setf cursor-x x)
 131                                     (setf cursor-y y))
 132                                   (when (or (> bp line-end)
 133                                             (>= p (length (buffer-data buf))))
 134                                     ;; Check if the rest of the line is blank
 135                                     (clear-to-eol y x w frame)
 136                                     (return-from col))
 137                                   ;; update attributes
 138                                   (when (>= bp next-prop)
 139                                     (turn-on-attributes (window-buffer w) bp))
 140                                   (let ((ch (elt (buffer-data buf) p)))
 141                                     ;; Update display
 142                                     (cond ((char= ch #\Newline)
 143                                            (putch #\Space x y w frame))
 144                                           (t
 145                                            (putch ch x y w frame)))
 146                                     ;; go to the next character in the buffer
 147                                     (incf p)
 148                                     (incf bp))))))))
 149         ;; Check if the bottom of the window needs to be erased.
 150         (when (< end (1- (window-height w)))
 151           (loop for i from end below (window-height w) do
 152                 (clear-to-eol i 0 w frame)))))
 153     ;; Update the mode-line if it exists. FIXME: Not the right place
 154     ;; to update the mode-line.
 155     (when (buffer-mode-line (window-buffer w))
 156       (update-mode-line (window-buffer w))
 157       (putstr (truncate-mode-line (window-buffer w) (window-width w))
 158               0 (window-height w nil) w frame)
 159       ;; don't forget the seperator on the modeline line
 160       (when (window-seperator w)
 161         (putch #\| (+ (window-x w) (window-width w)) (window-height w) w frame)))
 162     (reset-line-state w)
 163     ;; Set the cursor at the right spot
 164     (values cursor-x cursor-y)))
 165
 166 (defvar *mcl-stackgroup* (ccl:make-stack-group "lice")
 167   "")
 168
 169 (defun mcl-lice ()
 170   "Boot lice on mcl"
 171   (ccl:stack-group-preset *mcl-stackgroup* #'lice)
 172   (funcall *mcl-stackgroup* nil))
 173
 174 (ccl:defrecord Event
 175     (what integer)
 176   (message longint)
 177   (when longint)
 178   (where point)
 179   (modifiers integer))
 180
 181 (defvar *mcl-key-list* nil
 182   "List of keys pressed.")
 183
 184 (defmethod ccl:view-key-event-handler :after ((w mcl-window) ch)
 185   (declare (ignore ch))
 186   (let* ((keystroke (ccl:keystroke-name (ccl:event-keystroke (ccl:rref ccl:*current-event* :event.message) (ccl:rref ccl:*current-event* :event.modifiers))))
 187          (ch (if (listp keystroke)
 188                  (car (last keystroke))
 189                  keystroke))
 190          (mods (and (listp keystroke)
 191                     (butlast keystroke))))
 192     ;;(format t "k: ~s ~s ~s~%" keystroke ch mods)
 193     (setf *mcl-key-list* (nconc *mcl-key-list*
 194                                 (list (make-key
 195                                        :meta (and (find :meta mods) t)
 196                                        :control (and (find :control mods) t)
 197                                        :char ch))))
 198     (funcall *mcl-stackgroup* nil)))
 199
 200 (defmethod ccl:view-draw-contents ((win frame))
 201   (ccl:erase-rect win 0 0
 202                   (ccl:point-h (ccl:view-size win))
 203                   (ccl:point-v (ccl:view-size win)))
 204   ;; characters
 205   (loop
 206      for y from 0 below (array-dimension (frame-2d-double-buffer win) 0)
 207      for i from (mcl-frame-font-ascent win) by (mcl-frame-font-height win) do
 208        (loop
 209           for x from 0 below (array-dimension (frame-2d-double-buffer win) 1)
 210           for j from 0 by (mcl-frame-font-width win) do
 211             (ccl:move-to win j i)
 212             (princ (aref (frame-2d-double-buffer win) y x) win)))
 213   ;; point
 214   (let ((x (* (elt (mcl-frame-cursor win) 0) (mcl-frame-font-width win)))
 215         (y (* (elt (mcl-frame-cursor win) 1) (mcl-frame-font-height win))))
 216     (ccl:invert-rect win x y (+ x (mcl-frame-font-width win)) (+ y (mcl-frame-font-height win)))))
 217
 218 (defmethod frame-read-event ((frame mcl-frame))
 219   ;; wait for more input
 220   (unless *mcl-key-list*
 221     (ccl:stack-group-return nil))
 222   ;; process the new input
 223   (pop *mcl-key-list*))
 224
 225 (defun mcl-font-width (font-name font-size)
 226   (multiple-value-bind (ascent descent maxwidth leading) (ccl::font-info (list font-name font-size))
 227     (declare (ignore ascent descent leading))
 228     maxwidth))
 229
 230 (defun mcl-font-height (font-name font-size)
 231   (multiple-value-bind (ascent descent maxwidth leading) (ccl::font-info (list font-name font-size))
 232     (declare (ignore maxwidth))
 233     (+ ascent descent leading)))
 234
 235 (defun mcl-font-ascent (font-name font-size)
 236   (multiple-value-bind (ascent descent maxwidth leading) (ccl::font-info (list font-name font-size))
 237     (declare (ignore descent maxwidth leading))
 238     ascent))
 239
 240 (defun make-default-mcl-frame (buffer)
 241   (let* ((lines 25)
 242          (height (1- lines))
 243          (fw (mcl-font-width "Monaco" 12))
 244          (fh (mcl-font-height "Monaco" 12))
 245          (ascent (mcl-font-ascent "Monaco" 12))
 246          (cols 80)
 247          (l (make-array (* lines cols)
 248                         :element-type 'character))
 249          (d (make-array (list lines cols)
 250                         :element-type 'character
 251                         :displaced-to l :displaced-index-offset 0))
 252          (w (make-window :x 0 :y 0 :cols cols :rows height :buffer buffer))
 253          (mb (make-minibuffer-window lines cols))
 254          (frame (make-instance 'mcl-frame
 255                                :width cols
 256                                :height lines
 257                                :window-tree (list w mb)
 258                                :selected-window w
 259                                :minibuffer-window mb
 260                                :double-buffer l
 261                                :2d-double-buffer d
 262                                :font-height fh
 263                                :font-width fw
 264                                :font-ascent ascent
 265                                :view-size (ccl:make-point (* cols fw) (* lines fh))
 266                                :view-font '("Monaco" 12))))
 267     (setf (window-frame w) frame
 268           (window-frame mb) frame)
 269     frame))
 270