mcl-render.lisp

   1 (in-package :lice)
   2
   3 (defclass mcl-window (ccl:window)
   4   ())
   5
   6 (defclass mcl-frame (frame)
   7   ((mcl-window :type window :initarg :mcl-window :accessor mcl-frame-window)
   8    (double-buffer :type (array ccl:static-text-dialog-item 1) :initarg :double-buffer :accessor frame-double-buffer :documentation
   9                   "The display double buffer. This structure is compared to
  10 the characters we want to blit. Only differences are sent to the video
  11 hardware.")
  12    (2d-double-buffer :type (array ccl:static-text-dialog-item 2) :initarg :2d-double-buffer :accessor frame-2d-double-buffer :documentation
  13                      "Displaced from DISPLAY. This array is divided into rows and columns.")
  14    ))
  15
  16 (defmethod frame-start-render ((frame mcl-frame))
  17   )
  18
  19 (defmethod frame-end-render ((frame mcl-frame))
  20   (ccl:event-dispatch))
  21
  22
  23 (defun window-move-cursor (window x y)
  24   )
  25
  26 (defmethod frame-move-cursor ((frame mcl-frame) win x y)
  27   (window-move-cursor win x y))
  28
  29 (defun putch (ch x y window frame)
  30   (ccl:set-dialog-item-text (aref (frame-2d-double-buffer frame) (+ y (window-y window)) (+ x (window-x window)))
  31                             (string ch)))
  32
  33 (defun putstr (s x y w frame)
  34   (loop for i from 0 below (length s)
  35         for j from x by 1
  36         ;;if (char/= (aref (window-2d-display w) y j) (aref s i))
  37         do (putch (char s i) j y w frame)))
  38
  39 (defun clear-line-between (w y start end frame)
  40   "insert LEN spaces from START on line Y."
  41   (window-move-cursor w start y)
  42   ;; FIXME: this could be done faster
  43   (loop for i from start to end
  44         do (putch #\Space i y w frame)))
  45
  46 (defun clear-to-eol (y start window frame)
  47   (declare (type window window)
  48            (type fixnum y start))
  49   (let ((display (frame-2d-double-buffer frame))
  50         (linear (frame-double-buffer frame)))
  51     (clear-line-between window y start (1- (window-width window)) frame)
  52     ;; draw the seperator
  53     (when (window-seperator window)
  54       (putch #\| (+ (window-x window) (1- (window-width window t))) y window frame))))
  55
  56 (defun turn-on-attributes (buffer point)
  57   )
  58
  59 (defmethod window-render (w (frame mcl-frame))
  60   "Render a window."
  61   (let ((p (buffer-char-to-aref (window-buffer w) (marker-position (window-top w))))
  62         ;; current point in buffer buffer
  63         (bp (marker-position (window-top w)))
  64         (buf (window-buffer w))
  65         ;; The cursor point in the buffer. When the buffer isn't
  66         ;; current, then use the window's backup of the point.
  67         (point (window-point w))
  68         cursor-x
  69         cursor-y
  70         (cache-size (length (lc-cache (window-cache w))))
  71         (linear (frame-double-buffer frame))
  72         (display (frame-2d-double-buffer frame)))
  73     ;; Special case: when the buffer is empty
  74     (if (= (buffer-size (window-buffer w)) 0)
  75         (progn
  76           (dotimes (y (window-height w))
  77             (clear-to-eol y 0 w frame))
  78           (setf cursor-x 0
  79                 cursor-y 0))
  80       (let ((end (loop named row
  81                        for y below (window-height w)
  82                        for line from (window-top-line w) below cache-size
  83                        ;; return the last line, so we can erase the rest
  84                        finally (return-from row y)
  85                        ;; go to the next line
  86                        do (let* ((line-end (cache-item-end (item-in-cache w line)))
  87                                  (line-start (cache-item-start (item-in-cache w line)))
  88                                  (next-prop (next-single-property-change line-start :face (window-buffer w) line-end)))
  89                             (setf bp (cache-item-start (item-in-cache w line))
  90                                   p (buffer-char-to-aref (window-buffer w) bp))
  91                             ;; setup the display properties.
  92                             (turn-on-attributes (window-buffer w) bp)
  93                             (loop named col
  94                                 for x below (window-width w) do
  95                                 (progn
  96                                   ;; Skip the gap
  97                                   (when (= p (buffer-gap-start buf))
  98                                     (incf p (buffer-gap-size buf)))
  99                                   ;; Record point position on screen
 100                                   (when (eq bp point)
 101                                     (setf cursor-x x)
 102                                     (setf cursor-y y))
 103                                   (when (or (> bp line-end)
 104                                             (>= p (length (buffer-data buf))))
 105                                     ;; Check if the rest of the line is blank
 106                                     (clear-to-eol y x w frame)
 107                                     (return-from col))
 108                                   ;; update attributes
 109                                   (when (>= bp next-prop)
 110                                     (turn-on-attributes (window-buffer w) bp))
 111                                   (let ((ch (elt (buffer-data buf) p)))
 112                                     ;; Update display
 113                                     (cond ((char= ch #\Newline)
 114                                            (putch #\Space x y w frame))
 115                                           (t
 116                                            (putch ch x y w frame)))
 117                                     ;; go to the next character in the buffer
 118                                     (incf p)
 119                                     (incf bp))))))))
 120         ;; Check if the bottom of the window needs to be erased.
 121         (when (< end (1- (window-height w)))
 122           (loop for i from end below (window-height w) do
 123                 (clear-to-eol i 0 w frame)))))
 124     ;; Update the mode-line if it exists. FIXME: Not the right place
 125     ;; to update the mode-line.
 126     (when (buffer-mode-line (window-buffer w))
 127       (update-mode-line (window-buffer w))
 128       (putstr (truncate-mode-line (window-buffer w) (window-width w))
 129               0 (window-height w nil) w frame)
 130       ;; don't forget the seperator on the modeline line
 131       (when (window-seperator w)
 132         (putch #\| (+ (window-x w) (window-width w)) (window-height w) w frame)))
 133     (reset-line-state w)
 134     ;; Set the cursor at the right spot
 135     (values cursor-x cursor-y)))
 136
 137 (defmethod frame-read-event ((frame mcl-frame))
 138   (sleep 10)
 139   (make-instance 'key
 140                  :char #\a))
 141
 142 (defvar *mcl-key-list* nil
 143   "List of keys pressed.")
 144
 145 (defmethod view-key-event-handler :after ((w mcl-window) ch)
 146   (format t "LICE keypress: ~a~%" ch)
 147   (push ch *mcl-key-list*))
 148
 149 (defun make-default-mcl-frame (buffer)
 150   (let* ((lines 25)
 151          (height (1- lines))
 152          (cols 80)
 153          (l (make-array (* lines cols)
 154                         :element-type 'ccl:static-text-dialog-item))
 155          (d (make-array (list lines cols)
 156                         :element-type 'ccl:static-text-dialog-item
 157                         :displaced-to l :displaced-index-offset 0))
 158          (w (make-window :x 0 :y 0 :cols cols :rows height :buffer buffer))
 159          (mb (make-minibuffer-window lines cols))
 160          (frame (make-instance 'mcl-frame
 161                                :width cols
 162                                :height lines
 163                                :window-tree (list w mb)
 164                                :current-window w
 165                                :minibuffer-window mb
 166                                :double-buffer l
 167                                :2d-double-buffer d
 168                                :mcl-window (make-instance 'mcl-window
 169                                                           :view-size (ccl:make-point (* cols 11) (* lines 16))))))
 170     (dotimes (i (* cols lines))
 171       (setf (aref (frame-double-buffer frame) i) (make-instance 'ccl:static-text-dialog-item
 172                                                             :view-font '("Monaco" 12)
 173                                                             :view-container (mcl-frame-window frame)
 174                                                             :view-position (ccl:make-point (* (multiple-value-bind (q r) (truncate i cols) r) 11) (* (truncate i cols) 16))
 175                                                             :dialog-item-text (make-string 1 :initial-element #\-))))
 176     (setf (window-frame w) frame
 177           (window-frame mb) frame)
 178     frame))
 179