Commits

Paul Sexton  committed a10792a

Windows have a new slot, 'close-on-escape?'. If true, and the escape key is
pressed while the window has focus, and is not otherwise handled, the
window will close (become hidden).

For list-windows:
- the hotkey argument to 'window-add-item' is now a keyword
rather than an optional argument. This function takes another keyword
argument, prepend?. If true the item is added to the top of the list rather
than the bottom.
- a new slot, 'window-select-function'. Can be set to a function of two
arguments, which will be called when the window receives a gui-select-event.

Replace 'constrain' and 'constrain!' with alexandria's 'clamp' function.

  • Participants
  • Parent commits 2eecc4e

Comments (0)

Files changed (1)

File dormouse.lisp

            #:<Meter-Window>
            #:<List-Window>
            #:window-page-length
+           #:window-select-function
            #:<Menu-Window>
            #:<Alert-Window>
            #:<Yes/No-Window>
 (defgeneric window-items-lines (win)
   (:documentation   "Returns the total number of lines needed to display all
 the items in the window's list."))
-(defgeneric add-item (win item str &optional k)
+(defgeneric add-item (win item str &key hotkey prepend?)
   (:documentation   "Add an item to the end of the window's list.  ITEM is the
 'value' of the item itself. It can be any lisp value.  STR is a string
 representing ITEM, which is what is displayed in the window.  HOTKEY is an
     `(setf ,list-place (append ,list-place (list ,item))))
 
 
-
-(defun constrain (n lower-limit upper-limit)
-  "* Arguments:
-- N: a number.
-- LOWER-LIMIT: a number which is the lowest value that the function will return.
-- UPPER-LIMIT: a number which is the highest value that the function will return.
-
-* Description: Given a number N, Return N if the number is between LOWER-LIMIT
-and UPPER-LIMIT inclusive, otherwise return whichever of LOWER-LIMIT or
-UPPER-LIMIT is nearest to N.
-* See Also: {defmacro dormouse:constrain!}"
-  (cond
-    ((< n lower-limit)
-     lower-limit)
-    ((> n upper-limit)
-     upper-limit)
-    (t n)))
-
-
-
-(defmacro constrain! (place lower-limit upper-limit)
-  "* Arguments:
-- PLACE: a setf-able place that contains a number.
-- LOWER-LIMIT: a number which is the lowest value that the function will return.
-- UPPER-LIMIT: a number which is the highest value that the function will return.
-
-* Description: Destructively modifies PLACE, replacing its value with
-the value returned by (CONSTRAIN PLACE LOWER-LIMIT UPPER-LIMIT).
-* See Also: {defun dormouse:constrain}"
-  `(setf ,place (constrain ,place ,lower-limit ,upper-limit)))
-
-
-
 (defun keyword->string (kwd)
   "Given :MY-KEYWORD, returns the string 'MY-KEYWORD'."
   (string-trim '(#\:) (format nil "~A" kwd)))
 Examples: 'a', 'A', 'f1', 'Esc', 'Ctrl PgDn', 'ctrl alt M', 'C-x',
 'C-S-A-F12', 'shift-kp0'"
   (let* ((parts (cl-ppcre:split "[- ]" str))
+         (base (last-elt parts))
          (modifiers (mapcar #'string-downcase (butlast parts)))
-         (base (last-elt parts))
          (ch (cond
                ((= 1 (length base)) (aref base 0))
                ((string= base "minus") #\-)
                ((or (string= base "space")
                     (string= base "spc"))
                 #\space)
-               (t nil))))
+               (t nil)))
+         (ctrl? (if (or (find "c" modifiers :test #'string=)
+                                  (find "ctrl" modifiers :test #'string=)
+                                  (find "ctl" modifiers :test #'string=)
+                                  (find "control" modifiers :test #'string=))
+                    t nil))
+         (alt? (if (or (find "a" modifiers :test #'string=)
+                                 (find "alt" modifiers :test #'string=)
+                                 (find "m" modifiers :test #'string=)
+                                 (find "meta" modifiers :test #'string=))
+                   t nil))
+         (shift? (cond
+                            ((or (find "s" modifiers :test #'string=)
+                                 (find "shift" modifiers :test #'string=))
+                             t)
+                            (ch
+                             (character->shift ch))
+                             (t nil))))
     (tcod:make-key :c (or ch #\nul)
                    :vk (cond
                          (ch
                              (error "In key string ~S, unknown base key ~S"
                                     str base)))))
                    :pressed t
-                   :lalt (if (or (find "a" modifiers :test #'string=)
-                                 (find "alt" modifiers :test #'string=)
-                                 (find "m" modifiers :test #'string=)
-                                 (find "meta" modifiers :test #'string=))
-                             t nil)
-                   :lctrl (if (or (find "c" modifiers :test #'string=)
-                                  (find "ctrl" modifiers :test #'string=)
-                                  (find "ctl" modifiers :test #'string=)
-                                  (find "control" modifiers :test #'string=))
-                              t nil)
-                   :shift (cond
-                            ((or (find "s" modifiers :test #'string=)
-                                 (find "shift" modifiers :test #'string=))
-                             t)
-                            (ch
-                             (character->shift ch))
-                             (t nil)))))
+                   :lalt alt?
+                   :ralt alt?
+                   :lctrl ctrl?
+                   :rctrl ctrl?
+                   :shift shift?)))
 
 
 (let ((key-event nil))
             (centre-string text width))
            (t   ;; just a bar
             (spaces width))))
-        (filled-spaces (round (* width (/ (constrain num 0 denom) denom)))))
+        (filled-spaces (round (* width (/ (clamp num 0 denom) denom)))))
     (concatenate 'string
                  "{fg:" (keyword->string text-colour)
                  ",bg:" (keyword->string bar-colour) "}"
                       :initarg :can-close?
                       :documentation "Can the window be closed by clicking on
 an 'X' in its top right corner?")
+   (window-close-on-escape? :accessor window-close-on-escape?
+                            :initform nil :type boolean
+                            :initarg :close-on-escape?)
    (window-ephemeral? :accessor window-ephemeral? :initform nil
                       :type boolean :initarg :ephemeral?
                       :documentation "Ephemeral windows are destroyed
 (defmethod dirty-window ((win <Window>))
   (with-slots ((tlx window-tlx) (tly window-tly)
                (width window-width) (height window-height)) win
-    (console-set-dirty (constrain tlx 0 (1- (screen-width)))
-                       (constrain tly 0 (1- (screen-height)))
-                       (constrain width 0 (- (screen-width) tlx))
-                       (constrain height 0 (- (screen-height) tly)))))
+    (console-set-dirty (clamp tlx 0 (1- (screen-width)))
+                       (clamp tly 0 (1- (screen-height)))
+                       (clamp width 0 (- (screen-width) tlx))
+                       (clamp height 0 (- (screen-height) tly)))))
 
 
 
     (iterate
       (while (mouse-lbutton (setf rodent (mouse-get-status t))))
       ;; Update position of WIN based on mouse position
-      (setf tlx (constrain (- (mouse-cx rodent) offsetx)
-                           0 (- root-width width 1)))
-      (setf tly (constrain (- (mouse-cy rodent) offsety)
-                           0 (- root-height height 1)))
+      (setf tlx (clamp (- (mouse-cx rodent) offsetx)
+                       0 (- root-width width 1)))
+      (setf tly (clamp (- (mouse-cy rodent) offsety)
+                       0 (- root-height height 1)))
       (unless (and (= tlx (window-tlx win)) (= tly (window-tly win)))
         ;; copy saved win to root  at WIN's old position (erasing WIN)
         (console-blit *temp-con* 0 0
       (while (mouse-lbutton (setf rodent (mouse-get-status t))))
       ;; Update position of WIN based on mouse position.  Don't allow the mouse
       ;; to go above or to left of the top left corner of the window.
-      (setf brx (constrain (mouse-cx rodent) (window-tlx win)
-                           (1- (console-get-width *root*))))
-      (setf bry (constrain (mouse-cy rodent) (window-tly win)
-                           (1- (console-get-height *root*))))
+      (setf brx (clamp (mouse-cx rodent) (window-tlx win)
+                       (1- (console-get-width *root*))))
+      (setf bry (clamp (mouse-cy rodent) (window-tly win)
+                       (1- (console-get-height *root*))))
       (unless (and (= brx (window-brx win)) (= bry (window-bry win)))
         ;; copy saved win to root  at WIN's old position (erasing WIN)
         (console-blit *temp-con* 0 0
   ;; gui loop" keys.
   (let ((k (gui-event-keypress event)))
     (when (key-pressed k)
-      (when (and (member (key-vk k) (list :escape :f1))
-                 (or (key-lctrl k)
-                     (key-rctrl k))
-                 (not (key-shift k))
-                 (not (key-lalt k))
-                 (not (key-ralt k)))
-        (setf *exit-gui?* t)))))
+      (cond
+        ((and (member (key-vk k) (list :escape :f1))
+              (or (key-lctrl k)
+                  (key-rctrl k))
+              (not (key-shift k))
+              (not (key-lalt k))
+              (not (key-ralt k)))
+         (setf *exit-gui?* t))
+        ((and (window-close-on-escape? win)
+              (eql (key-vk k) :escape)
+              (not (key-shift k))
+              (not (key-lalt k))
+              (not (key-ralt k))
+              (not (key-lctrl k))
+              (not (key-rctrl k)))
+         (hide-window win))))))
 
 
 
    (window-cursor :accessor window-cursor :initform 0 :type integer)
    (window-use-borders? :initform nil :accessor window-use-borders?
                         :initarg :use-borders?
-                        :type boolean))
+                        :type boolean)
+   (window-select-function :initform nil :accessor window-select-function
+                           :initarg :select-function
+                           :type (or null function)
+                           :documentation
+                           "If supplied, a function of two arguments,
+WIN and ITEM. It will be called when the window receives a GUI-Select-Event."))
   (:documentation
    "Window that displays a list of strings which can be scrolled.
 
 
 
 
-(defmethod add-item ((win <List-Window>) item str &optional hotkey)
-  (push-end (make-list-item :str str :item item :hotkey hotkey)
-            (window-items win)))
+(defmethod add-item ((win <List-Window>) item str
+                     &key hotkey (prepend? nil))
+  (let ((litem (make-list-item :str str :item item :hotkey hotkey)))
+    (if prepend?
+        (push litem (window-items win))
+        (push-end litem (window-items win)))))
 
 
 (defmethod clear-items ((win <List-Window>))
     ;; Configure window
     (if (>= pagelen (window-items-lines win))
         (setf (window-offset win) 0))
-    (constrain! (window-cursor win) 0 (window-items-lines win))
+    (setf (window-cursor win)
+          (clamp (window-cursor win) 0 (window-items-lines win)))
     (if (< (window-cursor win) (window-offset win))
         (setf (window-offset win) (window-cursor win)))
     (if (>= (window-cursor win) (+ (window-offset win) pagelen))
                            :winx winx :winy winy)))))
 
 
+(defmethod send-to-window ((win <List-Window>) (event <GUI-Select-Event>))
+  (with-slots ((focus gui-event-focus)
+               (winx gui-event-winx) (winy gui-event-winy)) event
+    (if (window-select-function win)
+        (funcall (window-select-function win) win focus)
+        (call-next-method))))
+
+
+
 (defmethod send-to-window :around ((win <List-Window>) (event <Key-Event>))
   (with-slots ((winx gui-event-winx) (winy gui-event-winy)
                (k gui-event-keypress)) event
            (let ((matching (find-if #'(lambda (item)
                                         (and (key-p (list-item-hotkey item))
                                              (same-keys? (list-item-hotkey item) k)))
-                            (window-items win))))
+                                    (window-items win))))
              (cond
                (matching
                 (window-item-hotkey-pressed win matching))
                (t
                 (return-from send-to-window (call-next-method)))))))
-        ;;(constrain! (window-cursor win) 0 (max 0 (1- num-items)))
-        (constrain! (window-offset win)
-                    (1+ (- (window-cursor win) pagelen))
-                    (window-cursor win))
-        (constrain! (window-offset win) 0 (max 0 (- num-items pagelen)))
+        (setf (window-offset win)
+              (clamp (window-offset win)
+                     (1+ (- (window-cursor win) pagelen))
+                     (window-cursor win)))
+        (setf (window-offset win)
+              (clamp (window-offset win) 0 (max 0 (- num-items pagelen))))
         (prepare-window win)
         (redraw-window-area win)
         k))))
         (pagelen (window-page-length win)))
     (setf (window-offset win) (- num-items pagelen))
     (move-cursor-to win (1- num-items))
-    ;;(constrain! (window-cursor win) 0 (max 0 (1- num-items)))
-    (constrain! (window-offset win)
-                (1+ (- (window-cursor win) pagelen))
-                (window-cursor win))
-    (constrain! (window-offset win) 0 (max 0 (- num-items pagelen)))))
+    (setf (window-offset win)
+          (clamp (window-offset win)
+                 (1+ (- (window-cursor win) pagelen))
+                 (window-cursor win)))
+    (setf (window-offset win)
+          (clamp (window-offset win) 0 (max 0 (- num-items pagelen))))))
 
 
 
 
 
 
-(defmethod add-item :around ((win <Filtered-Window>) itemdata str &optional k)
-  (let ((item (make-list-item :str str :item itemdata :hotkey k)))
-    (push-end item (window-all-items win))
+(defmethod add-item :around ((win <Filtered-Window>) itemdata str
+                             &key hotkey (prepend? nil))
+  (let ((item (make-list-item :str str :item itemdata :hotkey hotkey)))
+    (if prepend?
+        (push item (window-all-items win))
+        (push-end item (window-all-items win)))
     (if (item-matches-filter-string? win item)
         (call-next-method))))
 
       (for item in (window-menu-items win))
       (destructuring-bind (value &key text key handler) item
         (print (list value text key handler))
-        (add-item win value text (if (characterp key)
-                                     (tcod-gui::make-simple-key key)))))))
+        (add-item win value text
+                  :hotkey (if (characterp key)
+                              (tcod-gui::make-simple-key key)))))))
 
 
 
        (resize-window win (window-width win) (min (- (screen-height) 2)
                                                   (+ (length items) 2)))
        (loop for item-desc-binding in items do
-            (destructuring-bind (item desc &optional binding) item-desc-binding
-              (add-item win item
-                        (format nil "~20A{yellow}~A{/}"
-                                desc
-                                (if binding
-                                    (key->string (binding->key binding))
-                                    ""))
-                        (if binding (binding->key binding)))))))
+         (destructuring-bind (item desc &optional binding) item-desc-binding
+           (add-item win item
+                     (format nil "~20A{yellow}~A{/}"
+                             desc
+                             (if binding
+                                 (key->string (binding->key binding))
+                                 ""))
+                     :hotkey (if binding (binding->key binding)))))))
     (move-cursor-to win (min (length items) cursor))
     (call-next-method)))
 
            (incf (window-offset win)))
           (otherwise
            (return-from send-to-window (call-next-method))))
-        ;; (warn "offset = ~D, cursor = ~D, num-items = ~D"
-        ;;            (window-offset win) (window-cursor win) num-items)
-        (constrain! (window-offset win) 0 (max 0 (- num-items pagelen)))
+        (setf (window-offset win)
+              (clamp (window-offset win) 0 (max 0 (- num-items pagelen))))
         (move-cursor-to win (window-offset win))
-        ;;(constrain! (window-cursor win) 0 (max 0 (1- num-items)))
-        ;; (warn "Now offset = ~D, cursor = ~D, num-items = ~D"
-        ;;            (window-offset win) (window-cursor win) num-items)
         (prepare-window win)
         (redraw-window-area win))
       k)))
       (if (> (length msg) (- (window-width win) 2))
           (wrap-items win)
           ;; else
-          (add-item win msg msg nil))
+          (add-item win msg msg :hotkey nil))
       (move-cursor-to-end win)
       (window-changed! win))))
 
         (num-items (length (window-items win))))
     (when (< num-items hgt)
       (dotimes (i (- hgt num-items))
-        (add-item win "" "" nil))
+        (add-item win "" "" :hotkey nil))
       (move-cursor-to-end win))))
 
 
-
-;;;     (setf (window-offset win) (- (length (window-items win))
-;;;                              (- (window-height win) 2)))
-;;;     (setf (window-cursor win) (1- (length (window-items win))))
-;;;     (constrain! (window-cursor win) 0 (max 0 (1- (length (window-items win)))))
-;;;     (constrain! (window-offset win) 0 (max 0 (- (length (window-items win))
-;;;                                             (- (window-height win) 2))))
-;;;     (prepare-window win)
-;;;     (redraw-window-area win)))
-
-
 (defmethod clear-messages ((win <Log-Window>))
   (setf (window-raw-messages win) nil)
   (setf (window-items win) nil)
                 (render-input-string win)))
              (t
               (return-from send-to-window (call-next-method))))
-           (constrain! (window-offset win) 0 (max 0 (- num-items pagelen)))
+           (setf (window-offset win)
+                 (clamp (window-offset win) 0 (max 0 (- num-items pagelen))))
            (move-cursor-to win (window-offset win))
-           ;;(constrain! (window-cursor win) 0 (max 0 (1- num-items)))
-           ;; (warn "Now offset = ~D, cursor = ~D, num-items = ~D"
-           ;;            (window-offset win) (window-cursor win) num-items)
            (prepare-window win)
            (redraw-window-area win))
          k))
         (oldx (window-tlx win))
         (oldy (window-tly win)))
     (move-window win
-                 (constrain
+                 (clamp
                   (cond
                     ((> *mouse-x* (- (screen-width) width))
                      (- *mouse-x* width))
                     (t
                      (1+ *mouse-x*)))
                   0 (- (screen-width) width 1))
-                 (constrain
+                 (clamp
                   (cond
                     ((> *mouse-y* (- (screen-height) height))
                      (- *mouse-y* height))
         ;; therefore cx - offsetx = current view-tlx
         ;;
         (setf deltax (- prev-cx
-                        (constrain (mouse-cx rodent)
-                                   (window-tlx win)
-                                   (window-brx win))))
+                        (clamp (mouse-cx rodent)
+                               (window-tlx win)
+                               (window-brx win))))
         (setf deltay (- prev-cy
-                        (constrain (mouse-cy rodent)
-                                   (window-tly win)
-                                   (window-bry win))))
+                        (clamp (mouse-cy rodent)
+                               (window-tly win)
+                               (window-bry win))))
         (unless (and (= deltax deltay 0))
           (unless started-dragging?
             (setf started-dragging? t)
         (t                              ; mouse "just hovering"
          (when *topwin*
            (setf (gui-event-winx mouse-hover-event)
-                 (constrain (- *mouse-x* (window-tlx *topwin*))
-                            0 (1- (window-width *topwin*))))
+                 (clamp (- *mouse-x* (window-tlx *topwin*))
+                        0 (1- (window-width *topwin*))))
            (setf (gui-event-winy mouse-hover-event)
-                 (constrain (- *mouse-y* (window-tly *topwin*))
-                            0 (1- (window-height *topwin*))))
+                 (clamp (- *mouse-y* (window-tly *topwin*))
+                        0 (1- (window-height *topwin*))))
            (setf (gui-event-mouse-state mouse-hover-event) *rodent*)
            (setf (gui-event-focus mouse-hover-event) nil)
            (send-to-window *topwin* mouse-hover-event))))