Commit 2f95963c authored by David O'Toole's avatar David O'Toole

check in spreadsheet code

parent 535302b8
(defun make-vector (n i)
(make-array n :initial-element i :adjustable t))
(defun make-grid (rows cols)
(let ((grid (make-vector rows nil)))
(dotimes (row rows)
(setf (aref grid row) (make-vector cols nil)))
grid))
(defun grid-get (grid row col)
(aref (aref grid row) col))
(defun grid-set (grid row col value)
(let ((row (aref grid row)))
(setf (aref row col) value)))
(defun grid-columns (grid)
(length (aref grid 0)))
(defun grid-rows (grid)
(length grid))
(defun vector-insert (oldvec pos elt)
"Insert ELT into VECTOR at POS, moving elements at POS and
afterward down the list."
(let* ((len (length oldvec))
(newvec (make-vector (+ len 1) nil)))
(dotimes (i (+ 1 len))
(setf (aref newvec i) (cond
(( < i pos)
(aref oldvec i))
(( equal i pos)
elt)
(( > i pos)
(aref oldvec (- i 1))))))
newvec))
(defun vector-delete (oldvec pos)
"Remove position POS from OLDVEC."
(let* ((len (length oldvec))
(newvec (make-vector (- len 1) nil)))
(dotimes (i (- len 1))
(setf (aref newvec i) (cond
(( < i pos)
(aref oldvec i))
(( >= i pos)
(aref oldvec (+ i 1))))))
newvec))
(defun grid-insert-row (grid row)
"Returns a new grid with a row inserted at row ROW. You should
replace the original grid with this one."
(let* ((newrow (make-vector (grid-columns grid) nil)))
(vector-insert grid row newrow)))
(defun grid-insert-column (grid col)
"Returns a new grid with a column inserted at column COL. You
should replace the original grid with this one."
(dotimes (i (grid-rows grid))
(setf (aref grid i) (vector-insert (aref grid i) col nil)))
grid)
(defun grid-delete-row (grid row)
"Returns a new grid with the row ROW removed. You should replace the original
grid with this one."
(vector-delete grid row))
(defun grid-delete-column (grid col)
"Returns a new grid with the column COL removed. You should
replace the original grid with this one."
(dotimes (i (grid-rows grid))
(setf (aref grid i) (vector-delete (aref grid i) col)))
grid)
(defclass sheet (buffer)
(top-margin :initform 18 :initarg :top-margin :accessor top-margin)
(node-spacing :initform 10 :initarg :node-spacing :accessor node-spacing)
(node-size :initform *default-node-size* :initarg :node-size :accessor node-size)
(snap-to-grid-p :initform t :initarg :snap-to-grid-p :accessor snap-to-grid-p)
(x-offset :initform 0 :initarg :x-offset :accessor x-offset)
(y-offset :initform 0 :initarg :x-offset :accessor x-offset))
(defmethod find-methods append ((sheet sheet)) '(arrange auto-arrange))
(defmethod node-stride ((sheet sheet))
(+ (node-size sheet)
(node-spacing sheet)))
(defmethod initialize-instance :after ((sheet sheet) &key)
(resize sheet *screen-width* *screen-height*)
(open-shell sheet)
(populate sheet))
(defmethod grid-position ((sheet sheet) x y)
(let ((stride (node-stride sheet))
(spacing (node-spacing sheet))
(top-margin (top-margin sheet)))
(values (+ spacing (* x stride))
(+ top-margin spacing (* y stride)))))
(defmethod place-node ((sheet sheet) (node node) x y)
;; (multiple-value-bind (ix iy) (grid-position sheet x y)
(move-to node x y))
(defmethod auto-resize ((node node) (sheet sheet))
(let ((size (node-size sheet)))
(resize node size size)))
(defmethod last-column ((sheet sheet))
(1- (length (aref (grid sheet) 0))))
(defmethod last-row ((sheet sheet))
(1- (length (grid sheet))))
(defmethod last-screen-column ((sheet sheet))
(1- (truncate (/ *screen-width* (node-stride sheet)))))
(defmethod last-screen-row ((sheet sheet))
(1- (truncate (/ *screen-height* (node-stride sheet))) 2))
(defmethod snap-to-grid ((node node) (sheet sheet))
(with-slots (x y) node
(place-node sheet node
(truncate (/ x (node-stride sheet)))
(truncate (/ y (node-stride sheet))))))
(defclass cell-sheet (sheet)
((grid :initform (make-grid 24 80) :accessor grid :initarg :grid)
(cursor-row :initform 0 :initarg :cursor-row :accessor cursor-row)
(cursor-column :initform 0 :initarg :cursor-column :accessor cursor-column)
(borders-p :initform nil :initarg :borders-p :accessor borders-p)
(headers-p :initform nil :initarg :headers-p :accessor headers-p)
(column-stops :initform nil :initarg :column-stops :accessor column-stops)))
(defmethod set-cell ((sheet sheet) (node node) row column)
(add-node sheet node)
(grid-set (grid sheet) row column node))
(defmethod get-cell ((sheet sheet) row column)
(grid-get (grid sheet) row column))
(defmethod cell ((sheet sheet) row column)
(get-cell sheet row column))
(defmethod (setf cell) ((node node) (sheet sheet) row column)
(set-cell sheet node row column))
;; (defmethod auto-arrange ((sheet cell-sheet))
(defmethod insert-row ((sheet sheet))
(with-slots (grid cursor-row) sheet
(setf grid (grid-insert-column grid cursor-row))))
(defmethod insert-column ((sheet sheet))
(with-slots (grid cursor-column) sheet
(setf grid (grid-insert-column grid cursor-column))))
(defmethod delete-row ((sheet sheet))
(with-slots (grid cursor-row) sheet
(setf grid (grid-delete-column grid cursor-row))))
(defmethod delete-column ((sheet sheet))
(with-slots (grid cursor-column) sheet
(setf grid (grid-delete-column grid cursor-column))))
(defmethod set-cursor ((sheet sheet) row column)
(setf (cursor-row sheet) row)
(setf (cursor-column sheet) column))
(defmethod move-cursor ((sheet sheet) direction)
(with-slots (grid cursor-row cursor-column) sheet
(let* ((rows (grid-rows grid))
(cols (grid-columns grid))
(new-cursor
(case direction
(:up (if (/= 0 cursor-row)
(list (- cursor-row 1) cursor-column)
cursor))
(:left (if (/= 0 cursor-column)
(list cursor-row (- cursor-column 1))
cursor))
(:down (if (< cursor-row (- rows 1))
(list (+ cursor-row 1) cursor-column)
cursor))
(:right (if (< cursor-column (- cols 1))
(list cursor-row (+ cursor-column 1))
cursor)))))
(destructuring-bind (row column) new-cursor
(set-cursor sheet row column)))))
(defmethod move-cursor-up ((sheet sheet))
(interactive)
(move-cursor sheet :up))
(defmethod move-cursor-left ((sheet sheet))
(interactive)
(move-cursor sheet :left))
(defmethod move-cursor-down ((sheet sheet))
(interactive)
(move-cursor sheet :down))
(defmethod move-cursor-right ((sheet sheet))
(interactive)
(move-cursor sheet :right))
(defmethod all-cells ((sheet sheet))
(let ((grid (grid sheet))
(cell nil)
(cells nil))
(dotimes (r (grid-rows grid))
(dotimes (c (grid-columns grid))
(when (setf cell (grid-get grid r c))
(push cell cells))))
(nreverse cells)))
(defparameter *sheet-header-font* "sans-9")
(defmethod header-width ((sheet sheet))
(font-text-width (format nil "~d" (grid-rows (grid sheet))) :font *sheet-header-font*))
(defmethod header-height ((sheet sheet))
(font-height *sheet-header-font*))
(defparameter *minimum-column-width* 12)
(defparameter *minimum-row-height* 12)
(defmethod layout ((sheet sheet))
(with-slots (grid cursor-row cursor-column headers-p borders-p) sheet
(let* ((rows (grid-rows grid))
(columns (grid-columns grid))
(column-width 0)
(row-height 0)
(cell-width 0)
(cell nil)
(row-header-width 0)
(column-header-height 0)
(widths (make-vector columns 0))
(heights (make-vector rows 0)))
;; compute row header width for along left side
(when headers-p
(setf row-header-width (header-width sheet))
(setf column-header-height (header-height sheet)))
;; compute widths of columns
(dotimes (col columns)
(setf column-width *minimum-column-width*)
(dotimes (row rows)
(setf cell (cell sheet row col))
(when cell
(layout cell)
(setf column-width (max column-width (width cell)))))
(setf (aref widths col) column-width))
;; compute heights of rows
(dotimes (row rows)
(setf row-height *minimum-row-height*)
(dotimes (col columns)
(setf cell (cell sheet row col))
(when cell
(setf row-height (max row-height (height cell)))))
(setf (aref heights row) row-height))
;; move objects
(dotimes (col columns)
(let ((x 0)
(y column-header-height))
(dotimes (row rows)
(setf x row-header-width)
(let ((cell (cell sheet row col)))
(when cell
(move-to cell x y)))
(incf x (aref widths col)))
(incf y (aref heights row)))))))
This diff is collapsed.
This diff is collapsed.
* Task list
** DONE [#A] revise/clean up/document new GUI code
CLOSED: [2017-04-24 Mon 20:18]
** TODO [#A] Desktop buffer-class for workspace / task / folder management
*** TODO Icon class
*** TODO auto layout simple line rules with spacing
*** TODO auto scale icons and grid with window
*** TODO monochrome icons
*** TODO themeable vertex colors
*** TODO 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 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 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
*** 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
** TODO [#A] command undo/redo
** TODO [#A] design layered tile map editing
......@@ -1234,3 +1237,27 @@
:ARCHIVE_CATEGORY: tasks
:ARCHIVE_TODO: DONE
:END:
** DONE [#A] revise/clean up/document new GUI code
CLOSED: [2017-04-24 Mon 20:18]
:PROPERTIES:
:ARCHIVE_TIME: 2017-04-25 Tue 07:13
:ARCHIVE_FILE: ~/xelf/tasks.org
:ARCHIVE_OLPATH: Task list
:ARCHIVE_CATEGORY: tasks
:ARCHIVE_TODO: DONE
:END:
** DONE [#A] Desktop buffer-class for workspace / task / folder management
CLOSED: [2017-04-25 Tue 07:13]
:PROPERTIES:
:ARCHIVE_TIME: 2017-04-25 Tue 07:13
:ARCHIVE_FILE: ~/xelf/tasks.org
:ARCHIVE_OLPATH: Task list
:ARCHIVE_CATEGORY: tasks
:ARCHIVE_TODO: DONE
:END:
*** TODO Icon class
*** TODO auto layout simple line rules with spacing
*** TODO auto scale icons and grid with window
*** TODO monochrome icons
(in-package :xelf)
(defparameter *default-icon-size* 64)
(defvar *icon-size* *default-icon-size*)
(defparameter *default-icon-color* "white")
(defparameter *icon-images*
'(:empty "icon-empty.png"
:caption "icon-caption.png"
:document "icon-document.png"
:folder "icon-folder.png"
:grid "icon-grid.png"
:open-folder "icon-open-folder.png"
:project "icon-project.png"))
(defun icon-image (name)
(getf *icon-images* name))
(defclass icon (node)
((image :initform (icon-image :empty) :initarg :image :accessor image)
(color :initform *default-icon-color* :initarg :color :accessor color)
(left-margin :initform 10 :initarg :left-margin :accessor left-margin)
(right-margin :initform 10 :initarg :right-margin :accessor right-margin)
(caption :initform "New Icon" :initarg :caption :accessor caption)
(action :initform nil :initarg :action :accessor action)))
(defmethod initialize-instance :after ((icon icon) &key)
(resize icon *icon-size* *icon-size*))
(defmethod draw ((icon icon))
(with-slots (x y width height caption color left-margin right-margin image) icon
(set-vertex-color color)
(draw-image image x y :width width :height height)
(set-vertex-color "white")
(draw-string caption (+ x left-margin) (- (+ y height) 25) :color "black" :font "sans-10")))
(defparameter *default-desktop-background-color* "gray40")
(defclass desktop (buffer)
((background-color :initform *default-desktop-background-color*)
(top-margin :initform 18 :initagr :top-margin :accessor top-margin)
(icon-spacing :initform 10 :initarg :icon-spacing :accessor icon-spacing)
(icon-size :initform *default-icon-size* :initarg :icon-size :accessor icon-size)
(snap-to-grid-p :initform t :initarg :snap-to-grid-p :accessor snap-to-grid-p)))
(defmethod icon-stride ((desktop desktop))
(+ (icon-size desktop)
(icon-spacing desktop)))
(defmethod initialize-instance :after ((desktop desktop) &key)
(open-shell desktop))
(defmethod grid-position ((desktop desktop) x y)
(let ((stride (icon-stride desktop))
(spacing (icon-spacing desktop))
(top-margin (top-margin desktop)))
(values (+ spacing (* x stride))
(+ top-margin spacing (* y stride)))))
(defmethod place-icon ((desktop desktop) (icon icon) x y)
(multiple-value-bind (ix iy) (grid-position desktop x y)
(move-to icon ix iy)))
(defmethod auto-resize ((icon icon) (desktop desktop))
(let ((size (icon-size desktop)))
(resize icon size size)))
(defmethod last-column ((desktop desktop))
(1- (truncate (/ *screen-width* (icon-stride desktop)))))
(defmethod last-row ((desktop desktop))
(- (truncate (/ *screen-height* (icon-stride desktop))) 2))
(defmethod snap-to-grid ((icon icon) (desktop desktop))
(with-slots (x y) icon
(place-icon desktop icon
(truncate (/ x (icon-stride desktop)))
(truncate (/ y (icon-stride desktop))))))
(defmethod arrange ((desktop desktop))
(dolist (icon (find-instances desktop 'icon))
(snap-to-grid icon desktop)
(auto-resize icon desktop)))
(defmethod auto-arrange-column ((desktop desktop) icons column)
(let ((row 0))
(dolist (icon icons)
(multiple-value-bind (x y) (grid-position desktop column row)
(place-icon desktop icon x y)
(incf row)))))
(defmethod auto-arrange ((desktop desktop))
(let* ((icons-per-column (1+ (last-row desktop)))
(last-column (last-column desktop))
(column last-column)
(icons (find-instances desktop 'icon)))
(loop while (and icons
(not (minusp column)))
do (if (> (length icons) icons-per-column)
(progn
(auto-arrange-column desktop (subseq icons 0 (1- icons-per-column)) column)
(setf icons (subseq icons icons-per-column)))
(auto-arrange-column desktop icons column))
do (decf column))))
......@@ -22,14 +22,14 @@
(with-session
(open-project :plong)
(index-pending-resources)
(let ((plong (make-instance 'plong-gui)))
(let ((plong (make-instance 'xelf::desktop)))
;; start the buffer running
(switch-to-buffer plong)
(at-next-update
(switch-to-buffer plong))))
;; (at-next-update
;; (add-node (current-buffer) (make-instance 'xelf::resize-buffer-dialog) 200 200)
;;(xelf::show-buffer-properties-dialog (current-buffer))
(bind-event (current-buffer) '(:f9) 'xelf::toggle-other-windows)
(start-game plong)))))
;; (bind-event (current-buffer) '(:f9) 'xelf::toggle-other-windows)
;; (start-game plong)))))
;; (trace xelf::evaluate)
;; (trace xelf::get-property-list)
......@@ -86,5 +86,13 @@
;; (trace xelf::populate)
;; (trace xelf::add-node)
;; (untrace xelf::layout)
;; (trace xelf::draw-cell)
;; (trace xelf::cell-bounding-box)
;; (trace xelf::draw-empty-cell)
;; (trace xelf::draw-string-in-cell)
;; (trace xelf::draw-row-header)
;; (trace xelf::draw-column-header)
(test-gui)
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