Commit 6fb61e95 authored by David O'Toole's avatar David O'Toole

double click icons and new buffer list

parent f29516f8
......@@ -501,18 +501,6 @@
(defun all-buffer-names ()
(loop for name being the hash-keys of *buffers* collect name))
(defclass buffer-list (text) ())
(defmethod tap :after ((buffer-list buffer-list) x y)
(with-slots (point-row) buffer-list
(at-next-update (switch-to-buffer (nth point-row (slot-value buffer-list 'buffer))))))
(defclass buffer-list-dialog (dialog)
((inputs :initform (list (make-instance 'buffer-list :text (all-buffer-names))))))
(defun show-buffer-list-dialog ()
(show-dialog (make-instance 'buffer-list-dialog) "Buffer list" :destroy-after-evaluate-p t))
;; User dialogs:1 ends here
;; Menu bar structure
......@@ -577,7 +565,11 @@
(:label "Resize to background image" :action do-resize-to-background-image)
(:label "Make snapshot" :action show-take-snapshot-dialog)
(:label "View clipboard" :action view-clipboard)
(:label "View buffer list" :action show-buffer-list-dialog))))
(:label "View buffer list" :action show-buffer-list))))
(defun show-buffer-list ()
(at-next-update
(switch-to-buffer (find-buffer "*buffer-list*" :create t :class 'buffer-list))))
(defun do-resize-to-background-image ()
(if (background-image (current-buffer))
......@@ -1130,6 +1122,11 @@ replace the original grid with this one."
(x-offset :initform 0 :initarg :x-offset :accessor x-offset)
(y-offset :initform 0 :initarg :x-offset :accessor x-offset)))
(defmethod top-margin ((sheet sheet))
(if (shell-p sheet)
(+ 8 (font-height *font*))
0))
(defmethod find-methods append ((sheet sheet)) '(clean-up auto-arrange toggle-snap-to-grid))
(defmethod node-stride ((sheet sheet))
......@@ -1306,7 +1303,8 @@ replace the original grid with this one."
(row-header-width 0)
(column-header-height 0)
(widths (make-vector columns 0))
(heights (make-vector rows 0)))
(heights (make-vector rows 0))
(top-margin (top-margin sheet)))
;; compute row header width for along left side
(setf row-header-width (header-width sheet))
(setf column-header-height (header-height sheet))
......@@ -1337,13 +1335,24 @@ replace the original grid with this one."
(when cell
(multiple-value-bind (top left right bottom)
(cell-bounding-box sheet row column)
(move-to cell left top)))))))))
(move-to cell left top)
(setf (fixed-width cell) (aref column-widths column))))))))))
(defmethod auto-arrange ((sheet cell-sheet))
(layout sheet))
(layout sheet))
(defmethod cell-at ((sheet sheet) x y)
(block finding
(dotimes (row (grid-rows (grid sheet)))
(dotimes (column (grid-columns (grid sheet)))
(let ((cell (cell sheet row column)))
(when (hit cell x y)
(return-from finding
(values cell row column))))))
(values nil nil nil)))
;; Cell spreadsheets:1 ends here
;; TODO Rendering cell sheets
;; Rendering cell sheets
;; [[file:~/xelf/gui.org::*Rendering%20cell%20sheets][Rendering cell sheets:1]]
......@@ -1351,10 +1360,9 @@ replace the original grid with this one."
(draw node))
(defmethod cell-bounding-box ((sheet cell-sheet) row column)
;; (setf row (min row (last-row sheet)))
;; (setf column (min column (last-column sheet)))
(let* ((top
(+ (header-height sheet)
(top-margin sheet)
(reduce #'+ (subseq (row-heights sheet)
0 row))))
(left
......@@ -1376,6 +1384,7 @@ replace the original grid with this one."
(defmethod row-header-bounding-box ((sheet cell-sheet) row)
(let* ((top
(+ (header-height sheet)
(top-margin sheet)
(reduce #'+ (subseq (row-heights sheet)
0 row))))
(left 0)
......@@ -1384,7 +1393,7 @@ replace the original grid with this one."
(values top left right bottom)))
(defmethod column-header-bounding-box ((sheet cell-sheet) column)
(let* ((top 0)
(let* ((top (top-margin sheet))
(left
(+ (header-width sheet)
(reduce #'+ (subseq (column-widths sheet)
......@@ -1421,8 +1430,44 @@ replace the original grid with this one."
(draw node))))
;; Rendering cell sheets:1 ends here
;; Buffer list sheet
;; [[file:~/xelf/gui.org::*Buffer%20list%20sheet][Buffer list sheet:1]]
(defclass buffer-list (cell-sheet) ())
(defmethod populate ((buffer-list buffer-list))
(setf (grid buffer-list) (make-grid (hash-table-count *buffers*) 2))
(let ((row 0))
(dolist (buffer-name (all-buffer-names))
(let ((buffer (find-buffer buffer-name)))
(setf (cell buffer-list row 0) (make-instance 'string-entry :value buffer-name))
(setf (cell buffer-list row 1) (make-instance 'property-value-entry :value (hash-table-count (objects buffer)))))
(incf row))))
(defmethod process-tap :after ((buffer-list buffer-list) (node node) x y)
(multiple-value-bind (cell row column) (cell-at buffer-list x y)
(when cell
(let ((buffer (get-value (cell buffer-list row 0))))
(at-next-update (switch-to-buffer buffer))))))
;; (defmethod tap :after ((buffer-list buffer-list) x y)
;; (with-slots (point-row) buffer-list
;; (at-next-update (switch-to-buffer (nth point-row (slot-value buffer-list 'buffer))))))
;; (defclass buffer-list-dialog (dialog)
;; ((inputs :initform (list (make-instance 'buffer-list :text (all-buffer-names))))))
;; (defun show-buffer-list-dialog ()
;; (show-dialog (make-instance 'buffer-list-dialog) "Buffer list" :destroy-after-evaluate-p t))
;; Buffer list sheet:1 ends here
;; Desktop
;; The included icons are inspired by the Xerox Star interface.
;; Ironically, when using SBCL these objects are also implemented via
;; PCL, the CLOS implementation written originally by Xerox.
;; [[file:~/xelf/gui.org::*Desktop][Desktop:1]]
(defparameter *default-icon-size* 64)
......@@ -1449,12 +1494,37 @@ replace the original grid with this one."
((image :initform (icon-image :empty) :initarg :image :accessor image)
(color :initform *default-icon-color* :initarg :color :accessor color)
(left-margin :initform 5 :initarg :left-margin :accessor left-margin)
(last-tap-time :initform nil)
(right-margin :initform 5 :initarg :right-margin :accessor right-margin)
(bottom-margin :initform 15 :initarg :bottom-margin :accessor bottom-margin)
(caption :initform nil :initarg :caption :accessor caption)
(action :initform nil :initarg :action :accessor action)))
(defmethod initialize-instance :after ((icon icon) &key)
(defparameter *double-tap-time* 8)
(defmethod tap ((self icon) x y)
(with-slots (last-tap-time) self
(let* ((time *updates*)
(elapsed-time (- time (or last-tap-time 0))))
(cond ((null last-tap-time)
(setf last-tap-time time))
((<= elapsed-time *double-tap-time*)
(setf last-tap-time nil)
(double-tap self x y))))))
(defmethod update :before ((self icon))
(with-slots (last-tap-time) self
;; we actually catch the end of single-click here.
(when (and last-tap-time
(> (- *updates* last-tap-time)
*double-tap-time*))
(setf last-tap-time nil)
(select self))))
(defmethod double-tap ((self icon) x y)
(evaluate self))
(defmethod initialize-instance :after ((icon icon) &key caption action)
(resize icon *icon-size* *icon-size*))
(defmethod draw ((icon icon))
......@@ -1465,7 +1535,7 @@ replace the original grid with this one."
(when caption
(draw-string caption (+ x left-margin) (- (+ y height) bottom-margin) :color "black" :font *icon-font*))))
(defparameter *default-desktop-background-color* "gray70")
(defparameter *default-desktop-background-color* "gray30")
(defclass desktop (sheet)
((background-color :initform *default-desktop-background-color*)
......@@ -1575,7 +1645,9 @@ replace the original grid with this one."
(make-instance 'folder-icon :buffer-name "Classes")
(make-instance 'folder-icon :buffer-name "Resources")
(make-instance 'folder-icon :buffer-name "Buffers")
(make-instance 'button-icon :image (icon-image :project) :action #'do-show-buffer-properties-dialog)))
(make-instance 'button-icon :image (icon-image :project)
:action #'show-buffer-list
:caption "Buffer List")))
(defmethod populate ((desktop desktop))
(dolist (icon (default-icons desktop))
......
......@@ -251,7 +251,7 @@
(find-object
(or (gethash name *buffers*)
(if create
(let ((buffer (make-instance (or class 'buffer))))
(let ((buffer (make-instance (or class 'buffer) :buffer-name name)))
(prog1 buffer (register-buffer buffer)))
(unless noerror
(error "Cannot find buffer ~S" name))))))
......@@ -1377,12 +1377,15 @@
(scroll-right it))
;; plain old click
(t
(tap it x y)))))
(process-tap self it x y)))))
;;(select self focused-block))
(setf click-start nil))))
;; clean up bookeeping
(clear-drag-data self))))
(defmethod process-tap ((self buffer) (tapped-node node) x y)
(tap tapped-node x y))
(defmethod release :around ((self buffer) x y &optional buttom)
(with-shell (call-next-method)))
......@@ -2208,13 +2211,13 @@ See sidebar for more commands to try.
(defmethod draw-input-area ((self prompt) state)
;; draw shaded area for data entry.
;; makes the cursor show up a bit better too.
(with-slots (x y label line) self
(with-slots (x y label line fixed-width) self
(assert (not (null line)))
(let ((label-width (label-width self))
(line-width (font-text-width line (slot-value self 'font))))
(draw-box (dash 0.5 x label-width)
(dash 0.2 y)
(dash 2 line-width)
(or fixed-width (dash 2 line-width))
(dash 0.8 (font-height (slot-value self 'font)))
:color (ecase state
(:active *active-prompt-color*)
......@@ -3411,11 +3414,13 @@ See sidebar for more commands to try.
(defmethod layout ((self entry))
(with-slots (height width value line) self
(setf height (+ 1 (* 1 *dash*) (font-height (slot-value self 'font))))
(setf width (+ 1 (* 2 *dash*)
(label-width self)
(max (slot-value self 'minimum-width)
(font-text-width line (slot-value self 'font)))))))
(setf width
(or (fixed-width self)
(+ 1 (* 2 *dash*)
(label-width self)
(max (slot-value self 'minimum-width)
(font-text-width line (slot-value self 'font))))))))
;;; Dropping words into phrases
(defmethod accept ((self entry) thing)
......@@ -4177,6 +4182,9 @@ See sidebar for more commands to try.
(category :initform :menu)
(tags :initform '(:menu))))
(defmethod find-methods append ((menu menu))
'(evaluate))
(defun menup (thing)
(typep (find-class 'menu) thing))
......
This diff is collapsed.
* Task list
** TODO allow double click
*** TODO configurable double click time
** TODO scrolling CellMode buffer
*** TODO tree with each row being a list of words
*** TODO passive layout child cell class
*** TODO review cell-mode code
** TODO allow recursive buffer view and split views
** TODO Fix FIND-BUFFER registration and too many buffers being created :initarg not respected
** TODO cursor movement
** TODO scrolling
** DONE function to determine what row/col was clicked widget
CLOSED: [2017-04-26 Wed 17:57]
** DONE change buffer list window into cell sheet
CLOSED: [2017-04-26 Wed 17:11]
** TODO [#A] allow recursive buffer view and split views
**** TODO buffer-proxy class
**** TODO fix project-window always before draw
**** TODO separate draw and draw-primary
** TODO themeable "index card pastel" vertex colors for folders
** TODO Design user experience
** DONE [#B] allow double click desktop icons
CLOSED: [2017-04-26 Wed 18:39]
** TODO [#B] Design user experience
*** TODO launching external programs to edit assets. gimp, audacity, switch-to-emacs,. etc
*** TODO folders are virtual views, they don't nest
** TODO [#A] change-buffer-class
......@@ -65,7 +67,9 @@
** TODO [#B] Factory class
** TODO [#B] Network class
** TODO [#B] Viewport class (buffer window)
** TODO [#C] themeable "index card pastel" vertex colors for folders
** TODO [#C] view-clipboard
** TODO [#C] configurable double click time
** TODO [#C] add more notifications for cut/copy etc
*** TODO Show yellow notification string on modeline
** TODO [#C] show-exit-dialog
......@@ -1261,3 +1265,16 @@
*** TODO auto layout simple line rules with spacing
*** TODO auto scale icons and grid with window
*** TODO monochrome icons
** DONE scrolling CellMode buffer
CLOSED: [2017-04-26 Wed 16:56]
:PROPERTIES:
:ARCHIVE_TIME: 2017-04-26 Wed 16:56
:ARCHIVE_FILE: ~/xelf/tasks.org
:ARCHIVE_OLPATH: Task list
:ARCHIVE_CATEGORY: tasks
:ARCHIVE_TODO: DONE
:END:
*** TODO tree with each row being a list of words
*** TODO passive layout child cell class
*** TODO review cell-mode code
......@@ -58,10 +58,10 @@ http://ccl.clozure.com/
Steel Bank Common Lisp (SBCL) is free software, and comes with
absolutely no warranty. Please see the file named
./licenses/COPYING.SBCL.txt The PCL implementation is (C) 1985-1990
Xerox Corporation.Portions of LOOP are Copyright (c) 1986 by the
Xerox Corporation. Portions of LOOP are Copyright (c) 1986 by the
Massachusetts Institute of Technology. Portions of LOOP are
Copyright (c) 1989-1992 by Symbolics, Inc.More information on SBCL
and complete source code may be found at the SBCL website: http://sbcl.org
Copyright (c) 1989-1992 by Symbolics, Inc. More information on SBCL and
complete source code may be found at the SBCL website: http://sbcl.org
")
(defvar *ecl-copyright-notice*
......@@ -5232,6 +5232,7 @@ Returns a newly allocated list."
(parent :initform nil :initarg :parent :accessor parent)
(inputs :initform nil :initarg :inputs :accessor inputs)
(results :initform nil :initarg :results :accessor results)
(fixed-width :initform nil :initarg :fixed-width :accessor fixed-width)
(input-widths :initform nil :initarg :input-widths :accessor input-widths)
(focused-p :initform nil :accessor focused-p)
(label :initform nil :initarg :label :accessor label)
......
......@@ -119,10 +119,10 @@ http://ccl.clozure.com/
Steel Bank Common Lisp (SBCL) is free software, and comes with
absolutely no warranty. Please see the file named
./licenses/COPYING.SBCL.txt The PCL implementation is (C) 1985-1990
Xerox Corporation.Portions of LOOP are Copyright (c) 1986 by the
Xerox Corporation. Portions of LOOP are Copyright (c) 1986 by the
Massachusetts Institute of Technology. Portions of LOOP are
Copyright (c) 1989-1992 by Symbolics, Inc.More information on SBCL
and complete source code may be found at the SBCL website: http://sbcl.org
Copyright (c) 1989-1992 by Symbolics, Inc. More information on SBCL and
complete source code may be found at the SBCL website: http://sbcl.org
")
(defvar *ecl-copyright-notice*
......@@ -5223,6 +5223,7 @@ subclasses.)
(parent :initform nil :initarg :parent :accessor parent)
(inputs :initform nil :initarg :inputs :accessor inputs)
(results :initform nil :initarg :results :accessor results)
(fixed-width :initform nil :initarg :fixed-width :accessor fixed-width)
(input-widths :initform nil :initarg :input-widths :accessor input-widths)
(focused-p :initform nil :accessor focused-p)
(label :initform nil :initarg :label :accessor label)
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment