Paul Sexton avatar 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
windows.

Comments (0)

Files changed (2)

     :depends-on ("tcod"
                  "iterate"
                  "alexandria"
-                 "cl-ppcre"))
+                 "cl-ppcre"
+                 "defstar"))
 
 
 ;;;; dormouse.asd ends here ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   (:nicknames :dormouse :tcod-gui :tcod.gui)
   (:use :cl :tcod
         :alexandria
-        :iterate)
+        :iterate
+        :defstar)
   (:shadow #:make-keyword)
   (:documentation
 "DORMOUSE is a windowing `graphical' user interface library, built on top of
            #:restore-interface-state
            #:destroy-interface-state
            #:hide-window
+           #:unhide-window
+           #:raise-window
            #:hide-all-windows
-           #:raise-window
            #:dirty-window
            #:move-window
            #:resize-window
            #:*window-theme*
            #:<Window>
            #:<Modal-Window>
+           #:modal?
            #:<Ghost-Window>
            #:<Background-Window>
            #:<Meter-Window>
            #:<List-Window>
+           #:window-page-length
            #:<Menu-Window>
            #:<Alert-Window>
            #:<Yes/No-Window>
            #:command-from-context-menu
            #:ok-to-show-tooltip?
            #:tooltip-text
+           #:floating-window
            #:floating-window-foreground
            #:floating-window-background
            #:calculate-floating-window-width
            #:window-items-lines
            #:clear-items  ;;
            #:list-item
+           #:list-item-str
            #:list-item-item
            #:list-item-hotkey
            #:list-item-p
            #:window-can-drag?
            #:window-can-resize?
            #:window-item-at-cursor
+           #:window-value-at-cursor
+           #:window-item->string
+           #:window-item-hotkey-pressed
            ;; Log window
            #:<Log-Window>
            #:clear-messages   ;;
            #:make-autolinks-in-hypertext-database
            #:hyperlink-foreground-colour
            #:open-hypertext-topic   ;;
-           ;; Terminal window
+           ;; [[Terminal window]] ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
            #:<Terminal-Window>
+           #:window-prompt
            #:window-input-function
            #:window-echo-input?
            #:window-input-active?
            #:window-input-history
+           #:send-string-to-terminal
            #:<Simple-Prompt-Window>
            ;; Viewports
            #:<Viewport>
            #:centre-viewport-on   ;;
            #:window-foreground
            #:window-background
+           #:window-highlight-foreground
+           #:window-highlight-background
            #:window-width
            #:window-height
            #:window-tlx
 * 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)
   (:documentation
    "* 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
                                 &allow-other-keys)
   (: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
   (: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))
   (cond
     ((and fg bg)
      ;; New in libtcod 1.4.3
     (t
      (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))))))
     (iterate
       (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))
   (:documentation
    "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"
                             pagewidth
                             (left-trim-coloured-string
-                             (format nil "~A" (list-item-str item))
+                             (window-item->string win item)
                              pagewidth))
                     winx winy
                     :bg (if cursor?
-                            (invert-colour
-                             (console-get-char-background
-                              (window-console win) 0 0))
+                            (window-highlight-background win)
                             nil))))
 
 
   (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))))
              (cond
                (matching
-                   (move-cursor-to win (position matching (window-items win))))
+                (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)))
 (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)))))
       (call-next-method)))
 
 
         (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))
 
 
     (cond
       ((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))))
            (cond
              ((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?
       (cond
         ((and (mouse-lbutton *rodent*)
-              *topwin*)
+              *topwin*
+              (not (window-hidden? *topwin*)))
          (raise-window *topwin*)
          (let ((start (get-internal-real-time))
                (dragged? nil))
Tip: Filter by directory path e.g. /media app.js to search for public/media/app.js.
Tip: Use camelCasing e.g. ProjME to search for ProjectModifiedEvent.java.
Tip: Filter by extension type e.g. /repo .js to search for all .js files in the /repo directory.
Tip: Separate your search with spaces e.g. /ssh pom.xml to search for src/ssh/pom.xml.
Tip: Use ↑ and ↓ arrow keys to navigate and return to view the file.
Tip: You can also navigate files with Ctrl+j (next) and Ctrl+k (previous) and view the file with Ctrl+o.
Tip: You can also navigate files with Alt+j (next) and Alt+k (previous) and view the file with Alt+o.