Commit b633eb60 authored by David O'Toole's avatar David O'Toole

add new icons and project code

parent e26fa163
......@@ -5129,3 +5129,8 @@ supported compiler.
`(glass-show :x ,x :y ,y)))
#+end_src
* Project wrapper class
......@@ -235,6 +235,10 @@ after-paste
aim
aim-at
align-to-pixels
all-buffers
all-images
all-music
all-samples
alternate-tap
always-bursting
analog-stick-heading
......@@ -248,6 +252,7 @@ background-stream
backward
backward-char
backward-delete-char
begin
begin-node-stream
beginning-of-line
below
......@@ -304,6 +309,7 @@ connectedp
connectingp
control-character-p
copy
create
create-buffer
create-path
create-project-image
......@@ -372,6 +378,7 @@ field-value
find-bounding-box
find-buffer
find-direction
find-file
find-heading
find-heading-direction
find-input
......@@ -533,12 +540,14 @@ method-arglist-for-swank
method-documentation
midpoint
minutes
modified-p
move
move-to
move-toward
move-window
move-window-to
move-window-to-node
name
new
newline
next-node
......@@ -552,6 +561,7 @@ objects
on-screen-p
opacity
open-client-socket
open-p
open-project
open-server-socket
open-shell
......@@ -560,12 +570,14 @@ opposite-heading
output-host
output-port
output-socket
package
parse-ip
paste
paste-as-new-buffer
paste-from
paste-here
paste-into
path
pause
paused
percent-gray
......@@ -590,9 +602,11 @@ process-sexp
process-state
process-time-out
process-xelf-object
project
project-orthographically
prompt
prompt-string
properties
quadtree
quadtree-collide
quadtree-delete
......@@ -647,6 +661,7 @@ right-of-center
role-indicator
run-hook
sample-playing-p
save
save-excursion
save-location
scale
......
......@@ -202,7 +202,15 @@
(:name "asterisk" :type :image :file "asterisk.png" :properties (:filter :linear))
(:name "circle-outline-flat-128" :type :image :file "circle-outline-flat-128.png" :properties (:filter :linear))
(:name "default-font" :type :ttf :file "DejaVuSans.ttf" :properties (:size 12))
(:name "icon-caption.png" :type :image :file "icon-caption.png")
(:name "icon-empty.png" :type :image :file "icon-empty.png")
(:name "icon-document.png" :type :image :file "icon-document.png")
(:name "icon-folder.png" :type :image :file "icon-folder.png")
(:name "icon-grid.png" :type :image :file "icon-grid.png")
(:name "icon-open-folder.png" :type :image :file "icon-open-folder.png")
(:name "icon-project.png" :type :image :file "icon-project.png")
(:name "up" :type :image :file "up.png")
(:name "down" :type :image :file "down.png")
(:name "left" :type :image :file "left.png")
......
#+TODO: TODO WORKING | DONE
* TODO Write Facade classes for subsystems
** TODO Project class
*** TODO current-project function to get object
*** TODO CREATE
*** TODO OPEN-P
*** TODO OPEN
*** TODO CLOSE
*** TODO PLAY
*** TODO PATH
*** TODO SAVE
*** TODO LOAD
*** TODO SAVE-BUFFER
*** TODO LOAD-BUFFER
*** TODO SAVE-SESSION
*** TODO LOAD-SESSION
*** TODO FIND-FILE
*** TODO FIND-SOUNDS
*** TODO FIND-IMAGES
*** TODO FIND-MUSIC
*** TODO FIND-BUFFERS
*** TODO EXPORT-APPLICATION
*** TODO EXPORT-ARCHIVE
* Task list
** TODO Desktop buffer-class for workspace / task / folder management
*** TODO Icon class
*** TODO monochrome icons
*** TODO themeable vertex colors
** WORKING System class for session management and device driver
** TODO Display class for screen properties and drawing
** TODO Resource class
*** TODO RELOAD
*** TODO PROPERTIES
*** TODO PROPERTY
*** TODO SETF PROPERTY
** TODO Emacs class
*** TODO EVAL-IN-EMACS
*** TODO SHOW-DEFINITION
*** TODO SHOW-EMACS
*** TODO SHOW-XELF
*** TODO TOGGLE-EMACS
** TODO Database class for serializing objects / variables
*** TODO WRITE-DATA
*** TODO READ-DATA
** TODO Gamepad class
** TODO Keyboard class
** TODO Properties class
** TODO Factory class
** TODO Network class
** TODO Viewport class (buffer window)
* TODO Change system menu to match new Facades
* Task list
** TODO [#C] change xelf system menu to dark colors
** TODO fix company-quickhelp not working in org (check portacle's config)
** TODO Design how to wrap subsystems in NODE subclasses
** TODO Fix PATH not being a NODE?
** TODO Workflow: company-mode and company-helpdoc?
** TODO [#A] fix ugly dialog boxes
......@@ -106,6 +58,54 @@
** TODO [#C] phrase fillout
** TODO [#C] Automate doc build
** TODO [#C] fix shutdown crash in TAP ENTRY
** TODO Project class
*** TODO current-project function to get object
*** TODO CREATE
*** TODO OPEN-P
*** TODO CLOSE
*** TODO PLAY
*** TODO PATH
*** TODO SAVE
*** TODO LOAD
*** TODO SAVE-BUFFER
*** TODO LOAD-BUFFER
*** TODO SAVE-SESSION
*** TODO LOAD-SESSION
*** TODO FIND-FILE
*** TODO FILES
*** TODO SOUNDS
*** TODO IMAGES
*** TODO MUSIC
*** TODO BUFFERS
*** TODO EXPORT-APPLICATION
*** TODO EXPORT-ARCHIVE
** WORKING System class for session management and device driver
** TODO Display class for screen properties and drawing
** TODO Resource class
*** TODO RELOAD
*** TODO PROPERTIES
*** TODO PROPERTY
*** TODO SETF PROPERTY
** TODO Emacs class
*** TODO EVAL-IN-EMACS
*** TODO SHOW-DEFINITION
*** TODO SHOW-EMACS
*** TODO SHOW-XELF
*** TODO TOGGLE-EMACS
** TODO Database class for serializing objects / variables
*** TODO WRITE-DATA
*** TODO READ-DATA
** TODO Gamepad class
** TODO Keyboard class
** TODO Properties class
** TODO Factory class
** TODO Network class
** TODO Viewport class (buffer window)
* TODO Change system menu to match new Facades
* TODO Design how to wrap subsystems in NODE subclasses
* TODO Write Facade classes for subsystems
* Archived Entries
......
......@@ -3154,6 +3154,15 @@ Returns a newly allocated list."
"The name of the current project.
This is set by OPEN-PROJECT; use that instead.")
(defvar *project-object* nil)
(defun set-current-project (object)
(assert (xelfp object))
(setf *project-object* object))
(defun current-project ()
*project-object*)
(defvar *recent-projects* nil)
;;; Project packages
......@@ -3287,6 +3296,9 @@ Returns a newly allocated list."
(defun sample-filename-p (name)
(eq :sample (resource-type-from-name name)))
(defun music-filename-p (name)
(eq :music (resource-type-from-name name)))
(defun image-filename-p (name)
(eq :image (resource-type-from-name name)))
......@@ -5467,9 +5479,6 @@ Returns a newly allocated list."
(defmethod finish-drag ((self node))
(bring-to-front self))
(defvar *buffers* nil
"When non-nil, the UUID of the current buffer object.")
(defmethod contains ((self node) block)
(block finding
(dolist (this (slot-value self 'inputs))
......@@ -6174,6 +6183,60 @@ Returns a newly allocated list."
;; defclass lower-command
;; Commands and undo/redo:1 ends here
;; Project object
;; [[file:~/xelf/xelf.org::*Project%20object][Project object:1]]
(defclass project (node)
((name :initform nil :initarg :name :accessor name)
(path :initform nil :initarg :path :accessor path)
(open-p :initform nil :accessor open-p)
(modified-p :initform nil :accessor modified-p)
(properties :initform nil :initarg :properties :accessor properties)))
(defmethod create-new ((project project) name &optional folder-name parent)
(setf (name project) name)
(let ((result (create-project-image name folder-name parent)))
(if (null result)
(error "Cannot create project.")
project)))
(defmethod begin ((project project))
(when (open-p project)
(error "Cannot open an already opened project."))
(open-project project)
(setf (path project) *project-path*)
(setf (open-p project) t)
(set-current-project project)
(index-pending-resources))
(defmethod save ((project project))
(when (open-p project)
(save-project project)
(set (modified-p project) nil)))
(defmethod find-file ((project project) file)
(find-project-file (name project) file))
(defmethod all-buffers ((project project))
(let (buffers)
(maphash #'(lambda (key value)
(push value buffers))
*buffers*)))
(defmethod all-images ((project project))
(when (open-p project)
(project-images)))
(defmethod all-samples ((project project))
(when (open-p project)
(project-samples)))
(defmethod all-music ((project project))
(remove-if-not #'music-filename-p
(cl-fad:list-directory (path project))))
;; Project object:1 ends here
;; Path class
......
......@@ -3174,6 +3174,15 @@ increases.
"The name of the current project.
This is set by OPEN-PROJECT; use that instead.")
(defvar *project-object* nil)
(defun set-current-project (object)
(assert (xelfp object))
(setf *project-object* object))
(defun current-project ()
*project-object*)
(defvar *recent-projects* nil)
;;; Project packages
......@@ -3305,6 +3314,9 @@ increases.
(defun sample-filename-p (name)
(eq :sample (resource-type-from-name name)))
(defun music-filename-p (name)
(eq :music (resource-type-from-name name)))
(defun image-filename-p (name)
(eq :image (resource-type-from-name name)))
......@@ -5450,9 +5462,6 @@ in the future.
(defmethod finish-drag ((self node))
(bring-to-front self))
(defvar *buffers* nil
"When non-nil, the UUID of the current buffer object.")
(defmethod contains ((self node) block)
(block finding
(dolist (this (slot-value self 'inputs))
......@@ -6154,6 +6163,60 @@ The Buffer class documentation continues on the [[file:gui.html][GUI page]].
Please see the [[file:gui.html][GUI page]] for code and documentation.
* Facade objects
** Project object
#+begin_src lisp
(defclass project (node)
((name :initform nil :initarg :name :accessor name)
(path :initform nil :initarg :path :accessor path)
(open-p :initform nil :accessor open-p)
(modified-p :initform nil :accessor modified-p)
(properties :initform nil :initarg :properties :accessor properties)))
(defmethod create-new ((project project) name &optional folder-name parent)
(setf (name project) name)
(let ((result (create-project-image name folder-name parent)))
(if (null result)
(error "Cannot create project.")
project)))
(defmethod begin ((project project))
(when (open-p project)
(error "Cannot open an already opened project."))
(open-project project)
(setf (path project) *project-path*)
(setf (open-p project) t)
(set-current-project project)
(index-pending-resources))
(defmethod save ((project project))
(when (open-p project)
(save-project project)
(set (modified-p project) nil)))
(defmethod find-file ((project project) file)
(find-project-file (name project) file))
(defmethod all-buffers ((project project))
(let (buffers)
(maphash #'(lambda (key value)
(push value buffers))
*buffers*)))
(defmethod all-images ((project project))
(when (open-p project)
(project-images)))
(defmethod all-samples ((project project))
(when (open-p project)
(project-samples)))
(defmethod all-music ((project project))
(remove-if-not #'music-filename-p
(cl-fad:list-directory (path project))))
#+end_src
* Pathfinding
We use the well-known [[https://en.wikipedia.org/wiki/A*_search_algorithm][A-star search algorithm]]. The main user-level
......
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