1. Paul Sexton
  2. cl-dormouse


Paul Sexton  committed 2eecc4e

Any window class can now behave modally, by specialising the 'modal?'
generic function.

console-draw-char-at is now a plain function, for better performance.

'defstar' library is now required (this should not pose a problem as cl-tcod
also requires it).

Further bugfixes around using window borders, and unhiding versus raising

  • Participants
  • Parent commits 75a9d8e
  • Branches default

Comments (0)

Files changed (2)

File dormouse.asd

View file
     :depends-on ("tcod"
-                 "cl-ppcre"))
+                 "cl-ppcre"
+                 "defstar"))
 ;;;; dormouse.asd ends here ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

File dormouse.lisp

View file
   (:nicknames :dormouse :tcod-gui :tcod.gui)
   (:use :cl :tcod
-        :iterate)
+        :iterate
+        :defstar)
   (:shadow #:make-keyword)
 "DORMOUSE is a windowing `graphical' user interface library, built on top of
+           #:unhide-window
+           #:raise-window
-           #:raise-window
+           #:modal?
+           #:window-page-length
+           #:floating-window
            #:clear-items  ;;
+           #:list-item-str
+           #:window-value-at-cursor
+           #:window-item->string
+           #:window-item-hotkey-pressed
            ;; Log window
            #:clear-messages   ;;
            #:open-hypertext-topic   ;;
-           ;; Terminal window
+           ;; [[Terminal window]] ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+           #:window-prompt
+           #:send-string-to-terminal
            ;; Viewports
            #:centre-viewport-on   ;;
+           #:window-highlight-foreground
+           #:window-highlight-background
 * Returns: None.
 * Description: Internal function, called by {defun dormouse:main-gui-loop}
 when the user uses the mouse to resize a window."))
-(defgeneric raise-window (win &key redraw simple-redraw? &allow-other-keys)
+(defgeneric raise-window (win &key &allow-other-keys)
    "* Arguments:
 - WIN: an instance of {defclass dormouse:<Window>}
-- REDRAW: boolean value indicating whether the area of the screen occupied
-by the window should be redrawn.
+- Keyword arguments:
+  - REDRAW: boolean value indicating whether the area of the screen occupied
+    by the window should be redrawn.
 * Returns: None.
 * Description: Put the window WIN at the top of the window stack, so that
 it is displayed as overlying any other overlapping windows.
                                 &key background-flag fg bg redraw
   (:documentation "TODO document."))
-(defgeneric console-draw-char-at (con ch winx winy
-                             &key background-flag fg bg &allow-other-keys)
-  (:documentation "TODO document."))
 (defgeneric draw-string-at (win str x y
                            &key fg bg redraw align &allow-other-keys)
   (:documentation   "Return the list-item that is at the current cursor
 position in this window (the 'cursor' moves up and down the list and always
 points to one of the items in the list)."))
+(defgeneric window-value-at-cursor (win))
 (defgeneric move-cursor-to-end (win)
   (:documentation "TODO document."))
 (defgeneric wrap-items (win)
   (check-type k key)
   (concatenate 'string
                (format nil "~A~A~A"
-                       (if (key-shift k) "shift-" "")
+                       (if (and (key-shift k)
+                                (not (character->shift (key-c k))))
+                           "shift-" "")
                        (if (or (key-rctrl k) (key-lctrl k)) "ctrl-" "")
                        (if (or (key-ralt k) (key-lalt k)) "alt-" ""))
                (case (key-vk k)
                    :shift (cond
                             ((or (find "s" modifiers :test #'string=)
                                  (find "shift" modifiers :test #'string=))
-                             (if ch
-                                 (tcod-gui:character->shift ch)
-                                 t))
-                            (t nil)))))
+                             t)
+                            (ch
+                             (character->shift ch))
+                             (t nil)))))
 (let ((key-event nil))
-(defmethod console-draw-char-at (con (ch integer) winx winy
-                             &key (background-flag :set)
-                                (fg nil) (bg nil))
+(defun* (console-draw-char-at -> (values)) ((con tcod:console)
+                                            (ch fixnum)
+                                            (winx fixnum) (winy fixnum)
+                                            &key (background-flag :set)
+                                                 (fg nil) (bg nil))
     ((and fg bg)
      ;; New in libtcod 1.4.3
      (console-put-char con winx winy ch background-flag)))
   ;; todo restore old values after printing
-  )
+  (values))
 (defmethod window-draw-char-at ((win <Window>) (ch character) winx winy
 ;;; <<Modal Window>> ==========================================================
+(defgeneric modal? (win)
+  (:documentation
+   "* Arguments:
+- WIN: an instance of [[<Window>]]
+* Returns: Boolean.
+* Description: Returns T if WIN is modal.")
+  (:method ((win <Window>)) nil))
 (defclass <Modal-Window> (<Window>)
   ((window-summon-mouse-on-raise? :initform nil
                                   :accessor window-summon-mouse-on-raise?
 can be sent to any other windows."
-(defun modal? (win)
-  "* Arguments:
-- WIN: an instance of [[<Window>]]
-* Returns: Boolean.
-* Description: Returns T if WIN inherits from [[<Modal-Window>]]."
-    (typep win '<Modal-Window>))
+(defmethod modal? ((win <Modal-Window>))
+  t)
 (defmethod raise-window :after ((win <Modal-Window>) &key)
                                                     (window-meters win))))))
       (for (text meter-type meter-fn) in (window-meters win))
-      (assert (eql :bar-chart meter-type))
+      (unless (eql :bar-chart meter-type)
+        (error "Meter type ~S not implemented" meter-type))
       (for row from 1)
       (for val = (funcall meter-fn))
       (if (>= row (window-height win)) (finish))
                   :initarg :offset :type integer)
    (window-cursor :accessor window-cursor :initform 0 :type integer)
    (window-use-borders? :initform nil :accessor window-use-borders?
+                        :initarg :use-borders?
                         :type boolean))
    "Window that displays a list of strings which can be scrolled.
   (nth (window-cursor win) (window-items win)))
+(defmethod window-value-at-cursor ((win <List-Window>))
+  (if (window-item-at-cursor win)
+      (values (list-item-item (window-item-at-cursor win)) t)
+      ;; else
+      (values nil nil)))
 (defmethod window-page-length ((win <List-Window>))
   (if (window-use-borders? win)
       (window-height win)
                         (= i (window-cursor win))))))
+(defgeneric window-item->string (win item))
+(defmethod window-item->string ((win <List-Window>) (item list-item))
+  (format nil "~A" (list-item-str item)))
 (defmethod draw-item-at ((win <List-Window>) (item list-item) winx winy cursor?)
   (let ((pagewidth (- (window-width win) (if (window-use-borders? win) 0 2))))
                     (format nil "~vA"
-                             (format nil "~A" (list-item-str item))
+                             (window-item->string win item)
                     winx winy
                     :bg (if cursor?
-                            (invert-colour
-                             (console-get-char-background
-                              (window-console win) 0 0))
+                            (window-highlight-background win)
   (move-cursor-to win (+ (window-cursor win) increment)))
+(defgeneric window-item-hotkey-pressed (win item))
+(defmethod window-item-hotkey-pressed ((win <list-window>) (item list-item))
+  (move-cursor-to win (position item (window-items win))))
 (defmethod send-to-window :around ((win <List-Window>) (event <Mouse-Hover-Event>))
   (with-slots ((winx gui-event-winx) (winy gui-event-winy)) event
                             (window-items win))))
-                   (move-cursor-to win (position matching (window-items win))))
+                (window-item-hotkey-pressed win matching))
                 (return-from send-to-window (call-next-method)))))))
         ;;(constrain! (window-cursor win) 0 (max 0 (1- num-items)))
 (defmethod item-matches-filter-string? ((win <Filtered-Window>) item)
   (or (null (filter-string win))
       (search (string-upcase (filter-string win))
-              (string-upcase (list-item-str item)))))
+              (string-upcase (window-item->string win item)))))
 (defmethod window-page-length ((win <Terminal-Window>))
   (if (window-input-active? win)
       (- (window-height win)
-         (max 1 (length (slot-value win 'window-input-rendered))))
+         (max 0 (1- (length (slot-value win 'window-input-rendered)))))
         (draw-string-at win (colourise (window-prompt win)
                                        (window-prompt-foreground win)
                                        (window-prompt-background win))
-                        1 -2))
+                        (if (window-use-borders? win) 0 1)
+                        (if (window-use-borders? win) -1 -2)))
       (when line
         (draw-string-at win (colourise line (window-input-foreground win)
                                        (window-input-background win))
-                        (if (zerop i) (+ (length (window-prompt win)) 1) 1)
-                        (- i 2))))))
+                        (+ (if (window-use-borders? win) 0 1)
+                           (if (zerop i) (length (window-prompt win)) 0))
+                        (- i (if (window-use-borders? win) 1 2)))))))
 (defmethod (setf window-input-string) :after (value (win <Terminal-Window>))
+  (declare (ignore value))
   (render-input-string win))
       ((window-input-active? win)
        (when (key-pressed k)
-         (let ((pagelen (- (window-height win) 2))
+         (let ((pagelen (window-page-length win))
                (num-items (length (window-items win))))
              ((graphic-char-p (key-c k))
 (defmethod tooltip-text :around ((win <Window>) datum winx winy)
   (declare (ignore datum winx winy))
-  (let ((result (call-next-method)))
-    (if (stringp result)
-        (list result)
+  (let ((res (call-next-method)))
+    (if (stringp res)
+        (list res)
         ;; else
-        result)))
+        res)))
       ;; Is a button being held down?
         ((and (mouse-lbutton *rodent*)
-              *topwin*)
+              *topwin*
+              (not (window-hidden? *topwin*)))
          (raise-window *topwin*)
          (let ((start (get-internal-real-time))
                (dragged? nil))