Commit 867c89b2 authored by David O'Toole's avatar David O'Toole

preliminary desktop code

parent b633eb60
This diff is collapsed.
......@@ -4,32 +4,26 @@
** TODO 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 [#C] change xelf system menu to dark colors
** TODO fix company-quickhelp not working in org (check portacle's config)
** TODO Fix PATH not being a NODE?
** TODO Workflow: company-mode and company-helpdoc?
** TODO [#A] fix ugly dialog boxes
** TODO [#A] create buffer switch menu
** TODO [#A] fix data entry widget validation
** TODO [#A] make each buffer have its own command-history?
** TODO [#A] button class
** TODO [#A] checkbox
** TODO [#A] radio buttons
** TODO [#A] dropdown list
** TODO [#A] fix disappearing shell prompt when clicking shell
** TODO [#A] controls for scrolling the buffer window
** TODO [#A] fix any move handle should move group
** TODO [#B] context-menus
** TODO [#B] fix can't drag item out of shell
** TODO [#B] command undo/redo
** TODO [#B] hand me a tile / reference
** TODO [#B] save-buffer
** TODO [#B] load-buffer
** TODO [#B] save-project
** TODO [#B] load-project
** TODO [#A] command undo/redo
** TODO [#A] fix can't drag item out of shell
** TODO [#A] context-menus
** TODO [#A] load-buffer
** TODO [#A] save-buffer
** TODO [#B] snap-to-grid and offset
** TODO [#B] hand me a tile / reference
** TODO [#B] select-all
** TODO [#B] general properties browser
*** TODO shell create/pop out 1 property of 1 object
......@@ -44,8 +38,11 @@
** TODO [#B] choose and export more accessor names for buffer/node slots
** TODO [#B] Document how to clear all caches
** TODO [#B] should block widgets be marked as :collision-type nil?
** TODO [#C] dropdown list
** TODO [#C] export-as-application
** TODO [#C] change xelf system menu to dark colors
** TODO [#C] change :no-background to :inhibit-background-p
** TODO [#C] radio buttons
** TODO [#C] fix POSITION-WITHIN-PARENT error on pressing TAB
** TODO [#C] right click pop up menus
** TODO [#C] pinnable pop up menus
......@@ -58,6 +55,9 @@
** TODO [#C] phrase fillout
** TODO [#C] Automate doc build
** TODO [#C] fix shutdown crash in TAP ENTRY
** TODO fix company-quickhelp not working in org (check portacle's config)
** TODO Fix PATH not being a NODE?
** TODO Workflow: company-mode and company-helpdoc?
** TODO Project class
*** TODO current-project function to get object
*** TODO CREATE
......
(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 snap-to-grid ((icon icon) (desktop desktop))
(with-slots (icon-spacing icon-size top-margin) 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)
......@@ -1851,31 +1851,31 @@ Returns a newly allocated list."
;; [[file:~/xelf/xelf.org::*Collision%20geometry%20tests][Collision geometry tests:1]]
(defun point-in-rectangle-p (x y width height o-top o-left o-width
(defun rectangle-in-rectangle-p (x y width height o-top o-left o-width
o-height)
(declare (single-float x y width height o-top o-left o-width o-height)
(optimize (speed 3)))
(not (or
;; is the top below the other bottom?
(<= (+ o-top o-height) y)
(< (+ o-top o-height) y)
;; is bottom above other top?
(<= (+ y height) o-top)
(< (+ y height) o-top)
;; is right to left of other left?
(<= (+ x width) o-left)
(< (+ x width) o-left)
;; is left to right of other right?
(<= (+ o-left o-width) x))))
(< (+ o-left o-width) x))))
(defmethod colliding-with-rectangle-p ((self quadrille) o-top o-left o-width o-height)
;; you must pass arguments in Y X order since this is TOP then LEFT
(multiple-value-bind (x y width height) (bounding-box* self)
(point-in-rectangle-p (cfloat x) (cfloat y) (cfloat width) (cfloat height)
(rectangle-in-rectangle-p (cfloat x) (cfloat y) (cfloat width) (cfloat height)
(cfloat o-top) (cfloat o-left) (cfloat o-width) (cfloat o-height))))
(defun colliding-with-bounding-box-p (self top left right bottom)
;; you must pass arguments in Y X order since this is TOP then LEFT
(multiple-value-bind (x y width height) (bounding-box* self)
(when (and width height)
(point-in-rectangle-p (cfloat x) (cfloat y) (cfloat width) (cfloat height)
(rectangle-in-rectangle-p (cfloat x) (cfloat y) (cfloat width) (cfloat height)
top left (- right left) (- bottom top)))))
(defgeneric colliding-with-p (this that)
......
......@@ -1907,7 +1907,7 @@ structure, and the Object Database.
** Collision geometry tests
#+begin_src lisp
(defun point-in-rectangle-p (x y width height o-top o-left o-width
(defun rectangle-in-rectangle-p (x y width height o-top o-left o-width
o-height)
(declare (single-float x y width height o-top o-left o-width o-height)
(optimize (speed 3)))
......@@ -1924,14 +1924,14 @@ structure, and the Object Database.
(defmethod colliding-with-rectangle-p ((self quadrille) o-top o-left o-width o-height)
;; you must pass arguments in Y X order since this is TOP then LEFT
(multiple-value-bind (x y width height) (bounding-box* self)
(point-in-rectangle-p (cfloat x) (cfloat y) (cfloat width) (cfloat height)
(rectangle-in-rectangle-p (cfloat x) (cfloat y) (cfloat width) (cfloat height)
(cfloat o-top) (cfloat o-left) (cfloat o-width) (cfloat o-height))))
(defun colliding-with-bounding-box-p (self top left right bottom)
;; you must pass arguments in Y X order since this is TOP then LEFT
(multiple-value-bind (x y width height) (bounding-box* self)
(when (and width height)
(point-in-rectangle-p (cfloat x) (cfloat y) (cfloat width) (cfloat height)
(rectangle-in-rectangle-p (cfloat x) (cfloat y) (cfloat width) (cfloat height)
top left (- right left) (- bottom top)))))
(defgeneric colliding-with-p (this that)
......
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