Commit 31a9d98b authored by David O'Toole's avatar David O'Toole

activate org-babel-tangle-jump-to-org

parent 51ca55dd
;; Shell commands
;; [[file:~/xelf/gui.org::*Shell%20commands][Shell commands:1]]
(in-package :xelf)
(defmethod set-caption-string ((self node) caption)
......@@ -31,7 +35,9 @@
(defmethod draw-caption ((self node) expression)
(draw-caption-string self (fancy-format-expression expression)))
;; Shell commands:1 ends here
;; [[file:~/xelf/gui.org::*Shell%20commands][Shell commands:2]]
(defmethod drag ((self shell) x y)
(with-slots (target-x target-y) self
(setf target-x (- x (window-x)))
......@@ -151,7 +157,12 @@
(defun shell-insert-output (object) (insert-output (shell) object))
(defun shell-destroy-output () (destroy-output (shell)))
(defun shell-evaluate-output () (evaluate-output (shell)))
;; Shell commands:2 ends here
;; Automatic layout
;; [[file:~/xelf/gui.org::*Automatic%20layout][Automatic layout:1]]
(defmethod update :after ((self shell))
(layout self)
(mapc #'layout (%inputs self))
......@@ -159,7 +170,12 @@
(when (and *menubar* (paused-p (current-buffer)))
(layout *menubar*)
(update *menubar*)))
;; Automatic layout:1 ends here
;; System object
;; [[file:~/xelf/gui.org::*System%20object][System object:1]]
(defvar *system* nil)
(defclass system (node)
......@@ -241,7 +257,12 @@
(defmethod exit-xelf* ((self system))
;; TODO destroy textures
(exit-xelf))
;; System object:1 ends here
;; User Commands
;; [[file:~/xelf/gui.org::*User%20Commands][User Commands:1]]
(define-dialog rename-buffer-dialog
((new-name (slot-value (current-buffer) 'buffer-name)))
(rename (current-buffer) new-name))
......@@ -265,7 +286,12 @@
(switch-to-buffer (make-instance 'buffer :name buffer-name))
(paste (current-buffer))
(trim (current-buffer)))
;; User Commands:1 ends here
;; Menu bar structure
;; [[file:~/xelf/gui.org::*Menu%20bar%20structure][Menu bar structure:1]]
(defparameter *project-menu*
'(:label "Project"
:inputs
......@@ -384,7 +410,12 @@
*help-menu*))))
(defparameter *system-menu* (system-menu-entries))
;; Menu bar structure:1 ends here
;; Menubar class
;; [[file:~/xelf/gui.org::*Menubar%20class][Menubar class:1]]
(defclass menubar (tree)
((category :initform :menu)
(temporary :initform t)))
......@@ -493,7 +524,12 @@
(defmethod accept ((self menubar) thing)
(declare (ignore thing))
nil)
;; Menubar class:1 ends here
;; Floating windows
;; [[file:~/xelf/gui.org::*Floating%20windows][Floating windows:1]]
(define-handle frame-close-button :close
:slots ((target-frame :initform nil :initarg :target-frame :accessor target-frame)))
......@@ -555,7 +591,12 @@
;; (defmethod as-drag ((self menu) x y)
;; (make-menu-frame self))
;; Floating windows:1 ends here
;; Context menus
;; [[file:~/xelf/gui.org::*Context%20menus][Context menus:1]]
(defmethod make-method-menu-item ((self node) method target)
(assert (and target (keywordp method)))
(let ((method-string (pretty-string method)))
......@@ -580,7 +621,12 @@
:expanded t
:locked t)
:target (find-uuid self)))))
;; Context menus:1 ends here
;; Command objects for undo/redo
;; [[file:~/xelf/gui.org::*Command%20objects%20for%20undo/redo][Command objects for undo/redo:1]]
(defclass command (node)
((action :initform nil :initarg :action :accessor action)
(target :initform nil :initarg :target :accessor target)
......@@ -591,7 +637,7 @@
(defmethod execute ((command command))
(setf (undo-action command)
(make-undo-action command))
(apply (function (action command))
(apply (symbol-function (action command))
(cons (target command)
(data command)))
(setf (executed-p command) t))
......@@ -626,3 +672,4 @@
(w0 width))
#'(lambda ()
(resize target w0 h0))))))
;; Command objects for undo/redo:1 ends here
This source diff could not be displayed because it is too large. You can view the blob instead.
This diff is collapsed.
This diff is collapsed.
......@@ -3,7 +3,7 @@
"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
<html xmlns="http://www.w3.org/1999/xhtml" lang="en" xml:lang="en">
<head>
<!-- 2017-04-10 Mon 06:03 -->
<!-- 2017-04-11 Tue 23:28 -->
<meta http-equiv="Content-Type" content="text/html;charset=utf-8" />
<meta name="viewport" content="width=device-width, initial-scale=1" />
<title>The game of Squareball</title>
......@@ -357,7 +357,7 @@ for the JavaScript code in this tag.
</li>
<li><a href="#org5fbc7be">Player robots</a>
<ul>
<li><a href="#orgb119950">Properties</a></li>
<li><a href="#orgb89fbe4">Properties</a></li>
<li><a href="#orga78f7de">Utilities</a></li>
<li><a href="#orgc5faa6b">Kicking the Squareball</a></li>
<li><a href="#org29bc0ce">Friction modification</a></li>
......@@ -417,7 +417,7 @@ for the JavaScript code in this tag.
<li><a href="#org4bbae53">Building the Arena buffer</a>
<ul>
<li><a href="#orga0483d0">A border around the playfield</a></li>
<li><a href="#org41798de">Properties</a></li>
<li><a href="#org704f3b8">Properties</a></li>
<li><a href="#org234d62d">Updating timers</a></li>
<li><a href="#org3d7bed4">Adding keybindings</a></li>
<li><a href="#org9e18cdd">Populating the board with objects</a></li>
......@@ -1589,9 +1589,9 @@ startup.
<div id="outline-container-org5fbc7be" class="outline-2">
<h2 id="org5fbc7be">Player robots</h2>
<div class="outline-text-2" id="text-org5fbc7be">
</div><div id="outline-container-orgb119950" class="outline-3">
<h3 id="orgb119950">Properties</h3>
<div class="outline-text-3" id="text-orgb119950">
</div><div id="outline-container-orgb89fbe4" class="outline-3">
<h3 id="orgb89fbe4">Properties</h3>
<div class="outline-text-3" id="text-orgb89fbe4">
<div class="org-src-container">
<pre class="src src-lisp">(<span style="color: #f47321;">defparameter</span> <span style="color: #da70d6;">*max-speed*</span> 2.4)
(<span style="color: #f47321;">defparameter</span> <span style="color: #da70d6;">*max-carry-speed*</span> 2.3)
......@@ -2649,9 +2649,9 @@ Pathfinding for Player 1 is turned off.
</div>
</div>
<div id="outline-container-org41798de" class="outline-3">
<h3 id="org41798de">Properties</h3>
<div class="outline-text-3" id="text-org41798de">
<div id="outline-container-org704f3b8" class="outline-3">
<h3 id="org704f3b8">Properties</h3>
<div class="outline-text-3" id="text-org704f3b8">
<div class="org-src-container">
<pre class="src src-lisp">(<span style="color: #f47321;">defclass</span> <span style="color: #83a525;">arena</span> (xelf:buffer)
((resetting <span style="color: #db7093;">:initform</span> nil)
......@@ -3424,7 +3424,7 @@ These strings are segregated here for easier localization and editing.
</div>
<div id="postamble" class="status">
<p class="author">Author: David O'Toole</p>
<p class="date">Created: 2017-04-10 Mon 06:03</p>
<p class="date">Created: 2017-04-11 Tue 23:28</p>
<p class="validation"><a href="http://validator.w3.org/check?uri=referer">Validate</a></p>
</div>
</body>
......
#+TITLE: The game of Squareball
#+OPTIONS: toc:3 *:nil
#+PROPERTY: header-args:lisp :results silent :noweb yes :tangle ../squareball/squareball.lisp
#+PROPERTY: header-args:lisp :results silent :noweb yes :tangle ../squareball/squareball.lisp :comments both
#+INFOJS_OPT: view:info mouse:underline up:index.html home:http://xelf.me toc:t ftoc:t ltoc:t
* Overview
......
This diff is collapsed.
......@@ -3,7 +3,7 @@
"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
<html xmlns="http://www.w3.org/1999/xhtml" lang="en" xml:lang="en">
<head>
<!-- 2017-04-11 Tue 22:44 -->
<!-- 2017-04-11 Tue 23:28 -->
<meta http-equiv="Content-Type" content="text/html;charset=utf-8" />
<meta name="viewport" content="width=device-width, initial-scale=1" />
<title>Xelf: eXtensible Emacs-Like Facility</title>
......@@ -419,7 +419,7 @@ for the JavaScript code in this tag.
<li><a href="#org17d29ff">Using UUIDs</a></li>
<li><a href="#org2fa1643">Destroying objects</a></li>
<li><a href="#org38918ba">Bounding box method</a></li>
<li><a href="#orga229057">Layout</a></li>
<li><a href="#orgfc13481">Layout</a></li>
<li><a href="#org67fccd3">Geometry utilities</a></li>
<li><a href="#orgf538113">Collision geometry tests</a></li>
<li><a href="#orgf9c4525">Movement</a></li>
......@@ -456,8 +456,8 @@ for the JavaScript code in this tag.
<li><a href="#org4fe6823">Physical size and nominal size</a></li>
<li><a href="#orga631364">Size measured in OpenGL coordinate units</a></li>
<li><a href="#orgc7c3eda">Scaling output to the system window</a></li>
<li><a href="#org8573aec">Orthographic projection&#xa0;&#xa0;&#xa0;<span class="tag"><span class="linux">linux</span>&#xa0;<span class="mac">mac</span>&#xa0;<span class="windows">windows</span></span></a></li>
<li><a href="#org20fab0a">Orthographic projection&#xa0;&#xa0;&#xa0;<span class="tag"><span class="android">android</span></span></a></li>
<li><a href="#org60ec000">Orthographic projection&#xa0;&#xa0;&#xa0;<span class="tag"><span class="linux">linux</span>&#xa0;<span class="mac">mac</span>&#xa0;<span class="windows">windows</span></span></a></li>
<li><a href="#org0927202">Orthographic projection&#xa0;&#xa0;&#xa0;<span class="tag"><span class="android">android</span></span></a></li>
</ul>
</li>
<li><a href="#org64777c1">Moving the camera in orthographic projection</a></li>
......@@ -497,8 +497,8 @@ for the JavaScript code in this tag.
<li><a href="#org881f6e5">Emulated vertex color&#xa0;&#xa0;&#xa0;<span class="tag"><span class="android">android</span></span></a></li>
<li><a href="#org36bf50a">Image objects</a>
<ul>
<li><a href="#orgfb0979a">Drawing images&#xa0;&#xa0;&#xa0;<span class="tag"><span class="linux">linux</span>&#xa0;<span class="mac">mac</span>&#xa0;<span class="windows">windows</span></span></a></li>
<li><a href="#org05088fb">Drawing images&#xa0;&#xa0;&#xa0;<span class="tag"><span class="android">android</span></span></a></li>
<li><a href="#org462b16f">Drawing images&#xa0;&#xa0;&#xa0;<span class="tag"><span class="linux">linux</span>&#xa0;<span class="mac">mac</span>&#xa0;<span class="windows">windows</span></span></a></li>
<li><a href="#orgf26dd0e">Drawing images&#xa0;&#xa0;&#xa0;<span class="tag"><span class="android">android</span></span></a></li>
<li><a href="#orgea58629">User-level image drawing function</a></li>
</ul>
</li>
......@@ -517,7 +517,7 @@ for the JavaScript code in this tag.
<ul>
<li><a href="#org3acb815">Z-order</a></li>
<li><a href="#org435c738">Destruction</a></li>
<li><a href="#org0fca924">Layout</a></li>
<li><a href="#org7e775f3">Layout</a></li>
<li><a href="#org6ea41cc">Making one or more nodes active&#xa0;&#xa0;&#xa0;<span class="tag"><span class="obsolete">obsolete</span></span></a></li>
<li><a href="#orgeca93d1">Automatic node sizing</a></li>
<li><a href="#org270b2a7">Scaling a node with respect to its image</a></li>
......@@ -650,7 +650,10 @@ strings, a section might be left without commentary on purpose.
<p>
The <a href="https://gitlab.com/dto/xelf/blob/master/doc.lisp">documentation extraction code</a> is included. Hierarchical
organization of the source code helps both browsing and coding via
<a href="http://orgmode.org/worg/org-contrib/babel/">org-babel</a>. See also <a href="http://orgmode.org/worg/org-contrib/babel/languages/ob-doc-lisp.html">the org-babel-lisp</a> documentation.
<a href="http://orgmode.org/worg/org-contrib/babel/">org-babel</a>. Debugger and browser references to tangled output can be
instantly redirected to the correct location in the literate Org file
(see the notes at the bottom of <a href="http://orgmode.org/manual/Extracting-source-code.html#Extracting-source-code">this Orgmode manual page</a>. See also <a href="http://orgmode.org/worg/org-contrib/babel/languages/ob-doc-lisp.html">the
org-babel-lisp</a> documentation.
</p>
<blockquote>
......@@ -2880,9 +2883,9 @@ structure, and the Object Database.
</div>
</div>
<div id="outline-container-orga229057" class="outline-3">
<h3 id="orga229057">Layout</h3>
<div class="outline-text-3" id="text-orga229057">
<div id="outline-container-orgfc13481" class="outline-3">
<h3 id="orgfc13481">Layout</h3>
<div class="outline-text-3" id="text-orgfc13481">
<div class="org-src-container">
<pre class="src src-lisp"> (<span style="color: #f47321;">defmethod</span> <span style="color: #9370db;">layout</span> ((self quadrille)) nil)
</pre>
......@@ -4090,9 +4093,9 @@ increases.
</div>
</div>
<div id="outline-container-org8573aec" class="outline-4">
<h4 id="org8573aec">Orthographic projection&#xa0;&#xa0;&#xa0;<span class="tag"><span class="linux">linux</span>&#xa0;<span class="mac">mac</span>&#xa0;<span class="windows">windows</span></span></h4>
<div class="outline-text-4" id="text-org8573aec">
<div id="outline-container-org60ec000" class="outline-4">
<h4 id="org60ec000">Orthographic projection&#xa0;&#xa0;&#xa0;<span class="tag"><span class="linux">linux</span>&#xa0;<span class="mac">mac</span>&#xa0;<span class="windows">windows</span></span></h4>
<div class="outline-text-4" id="text-org60ec000">
<div class="org-src-container">
<pre class="src src-lisp"> #+(or linux darwin win32
(and win32 64-bit) <span style="color: #999999; font-style: italic;">;; </span><span style="color: #7f7f7f; font-style: italic;">sbcl</span>
......@@ -4115,9 +4118,9 @@ increases.
</div>
</div>
<div id="outline-container-org20fab0a" class="outline-4">
<h4 id="org20fab0a">Orthographic projection&#xa0;&#xa0;&#xa0;<span class="tag"><span class="android">android</span></span></h4>
<div class="outline-text-4" id="text-org20fab0a">
<div id="outline-container-org0927202" class="outline-4">
<h4 id="org0927202">Orthographic projection&#xa0;&#xa0;&#xa0;<span class="tag"><span class="android">android</span></span></h4>
<div class="outline-text-4" id="text-org0927202">
<div class="org-src-container">
<pre class="src src-lisp"> <span style="color: #ff00ff; font-style: italic;">#+android</span>
<span style="color: #ff00ff; font-style: italic;"> (defun project-orthographically (&amp;optional (depth-test t))</span>
......@@ -5784,9 +5787,9 @@ This is for OpenGL ES 2 on Android, and not currently documented.
</div>
</div>
<div id="outline-container-orgfb0979a" class="outline-3">
<h3 id="orgfb0979a">Drawing images&#xa0;&#xa0;&#xa0;<span class="tag"><span class="linux">linux</span>&#xa0;<span class="mac">mac</span>&#xa0;<span class="windows">windows</span></span></h3>
<div class="outline-text-3" id="text-orgfb0979a">
<div id="outline-container-org462b16f" class="outline-3">
<h3 id="org462b16f">Drawing images&#xa0;&#xa0;&#xa0;<span class="tag"><span class="linux">linux</span>&#xa0;<span class="mac">mac</span>&#xa0;<span class="windows">windows</span></span></h3>
<div class="outline-text-3" id="text-org462b16f">
<div class="org-src-container">
<pre class="src src-lisp"> #+(or linux darwin win32
(and win32 64-bit) <span style="color: #999999; font-style: italic;">;; </span><span style="color: #7f7f7f; font-style: italic;">sbcl</span>
......@@ -5881,9 +5884,9 @@ This is for OpenGL ES 2 on Android, and not currently documented.
</div>
</div>
<div id="outline-container-org05088fb" class="outline-3">
<h3 id="org05088fb">Drawing images&#xa0;&#xa0;&#xa0;<span class="tag"><span class="android">android</span></span></h3>
<div class="outline-text-3" id="text-org05088fb">
<div id="outline-container-orgf26dd0e" class="outline-3">
<h3 id="orgf26dd0e">Drawing images&#xa0;&#xa0;&#xa0;<span class="tag"><span class="android">android</span></span></h3>
<div class="outline-text-3" id="text-orgf26dd0e">
<div class="org-src-container">
<pre class="src src-lisp"> <span style="color: #ff00ff; font-style: italic;">#+android</span>
<span style="color: #ff00ff; font-style: italic;"> (defun ensure-arrays ()</span>
......@@ -6621,9 +6624,9 @@ subclasses.)
</div>
</div>
<div id="outline-container-org0fca924" class="outline-3">
<h3 id="org0fca924">Layout</h3>
<div class="outline-text-3" id="text-org0fca924">
<div id="outline-container-org7e775f3" class="outline-3">
<h3 id="org7e775f3">Layout</h3>
<div class="outline-text-3" id="text-org7e775f3">
<div class="org-src-container">
<pre class="src src-lisp"> (<span style="color: #f47321;">defmethod</span> <span style="color: #9370db;">layout</span> <span style="color: #db7093;">:after</span> ((self node))
(<span style="color: #f47321;">with-slots</span> (halo) self
......@@ -9559,7 +9562,7 @@ literate source on that page. See also <a href="dictionary/WILL-OBSTRUCT-P.html"
</div>
<div id="postamble" class="status">
<p class="author">Author: David O'Toole &lt;dto@xelf.me&gt;</p>
<p class="date">Created: 2017-04-11 Tue 22:44</p>
<p class="date">Created: 2017-04-11 Tue 23:28</p>
<p class="validation"><a href="http://validator.w3.org/check?uri=referer">Validate</a></p>
</div>
</body>
......
......@@ -22,6 +22,17 @@
(require 'cl)
(defun eval-in-cl (cl-expression-string &optional process-result-values)
(slime-eval-async `(swank:eval-and-grab-output ,cl-expression-string)
(lexical-let ((here (current-buffer))
(process-result-values process-result-values))
(lambda (result-values)
(when process-result-values
(set-buffer here)
(funcall process-result-values (rest result-values)))))))
(setq slime-enable-evaluate-in-emacs t)
;; Emacs glass frame is transparent
(defvar glass-transparent-alpha 80)
......@@ -150,7 +161,7 @@
(defun glass-toggle-play ()
(interactive)
(eval-in-cl "(blocky:toggle-play)"))
(eval-in-cl "(xelf::toggle-play)"))
(global-set-key [f12] 'glass-toggle)
(global-set-key [pause] 'glass-toggle-play)
......@@ -173,5 +184,7 @@
(let ((height (min 16 (max 8 (count-lines (point-min) (point-max))))))
(set-frame-height glass-frame height))))
;; (glass-show :x 20 :y 200 :width 78 :height 14)
(provide 'glass)
;;; glass.el ends here
;; Package declaration
;; [[file:~/xelf/gui.org::*Package%20declaration][Package declaration:1]]
(in-package :xelf)
;; Package declaration:1 ends here
;; Basic help text
;; [[file:~/xelf/gui.org::*Basic%20help%20text][Basic help text:1]]
(defparameter *help-text*
"Welcome to Xelf.
......@@ -17,7 +26,16 @@ Toggle minibuffer view: F9 Pause/unpause: F12
See sidebar for more commands to try.
")
;; Basic help text:1 ends here
;; Indicator icons
;; The GUI handles that make up each "halo" use a special standard icon
;; set included with Xelf. See also "Loading standard fonts and icons"
;; above.
;; [[file:~/xelf/gui.org::*Indicator%20icons][Indicator icons:1]]
(defparameter *active-indicator-color* "yellow")
(defparameter *inactive-indicator-color* "gray70")
......@@ -67,7 +85,12 @@ See sidebar for more commands to try.
(or color (ecase state
(:active *active-indicator-color*)
(:inactive *inactive-indicator-color*))))))
;; Indicator icons:1 ends here
;; Clipboard
;; [[file:~/xelf/gui.org::*Clipboard][Clipboard:1]]
(defvar *clipboard* nil)
(defun initialize-clipboard-maybe (&optional force)
......@@ -80,7 +103,12 @@ See sidebar for more commands to try.
(defun clipboard ()
(initialize-clipboard-maybe)
*clipboard*)
;; Clipboard:1 ends here
;; Text keybindings
;; [[file:~/xelf/gui.org::*Text%20keybindings][Text keybindings:1]]
(defun bind-event-to-text-insertion (self key mods text)
(bind-event-to-task self key mods
(make-instance 'task :insert-string self (list text))))
......@@ -156,7 +184,12 @@ See sidebar for more commands to try.
(etypecase result
(symbol (bind-event-to-method self key mods result))
(string (bind-event-to-text-insertion self key mods result)))))))
;; Text keybindings:1 ends here
;; Mouse events
;; [[file:~/xelf/gui.org::*Mouse%20events][Mouse events:1]]
(defmethod select ((self node)) nil)
(defmethod alternate-tap ((self node) x y))
......@@ -227,7 +260,12 @@ See sidebar for more commands to try.
(focus-on (current-buffer) self :clear-selection nil))
(defmethod pick-focus ((self node)) self)
;; Mouse events:1 ends here
;; Halos
;; [[file:~/xelf/gui.org::*Halos][Halos:1]]
(defparameter *handle-scale* 3.2)
(defparameter *handle-highlight-background-color* "gray50")
......@@ -506,7 +544,12 @@ See sidebar for more commands to try.
(defmethod draw-focus ((self halo)))
(defmethod draw-highlight ((self halo)))
(defmethod accept ((self halo) other))
;; Halos:1 ends here
;; Opening a halo
;; [[file:~/xelf/gui.org::*Opening%20a%20halo][Opening a halo:1]]
;; see also halo.lisp
(defmethod make-halo ((self node))
......@@ -539,7 +582,12 @@ See sidebar for more commands to try.
(defmethod can-escape ((self node))
t)
;; Opening a halo:1 ends here
;; Visibility
;; [[file:~/xelf/gui.org::*Visibility][Visibility:1]]
(defmethod show ((self node))
(setf (slot-value self 'visible) t))
......@@ -553,7 +601,12 @@ See sidebar for more commands to try.
(defmethod visiblep ((self node))
(slot-value self 'visible))
;; Visibility:1 ends here
;; Data entry prompt
;; [[file:~/xelf/gui.org::*Data%20entry%20prompt][Data entry prompt:1]]
(defvar *prompt* nil)
(defparameter *active-prompt-color* "red")
......@@ -864,7 +917,11 @@ See sidebar for more commands to try.
(defmethod draw :after ((self buffer))
(when *notification*
(draw *notification*)))
;; Data entry prompt:1 ends here
;; System terminal
;; [[file:~/xelf/gui.org::*System%20terminal][System terminal:1]]
;;; Terminal display
(defvar *terminal-lines* nil)
......@@ -934,7 +991,15 @@ See sidebar for more commands to try.
(defun draw-terminal-maybe (&optional number-of-lines translucent)
(when (plusp *terminal-timer*)
(draw-terminal number-of-lines translucent)))
;; System terminal:1 ends here
;; Rendering Smalltalk style controls
;; This section implements drawing primitives and color themes for a
;; hybrid GUI inspired by MIT Scratch and its derivatives.
;; [[file:~/xelf/gui.org::*Rendering%20Smalltalk%20style%20controls][Rendering Smalltalk style controls:1]]
(defparameter *background-color* "white"
"The default background color of the XELF user interface.")
......@@ -1306,7 +1371,12 @@ See sidebar for more commands to try.
:color *hover-color* :alpha *hover-alpha*)
(dolist (input inputs)
(draw input))))
;; Rendering Smalltalk style controls:1 ends here
;; Layout
;; [[file:~/xelf/gui.org::*Layout][Layout:1]]
(defmethod draw-ghost ((self node))
(with-slots (x y width height) self
(draw-patch self x y (+ x width) (+ y height)
......@@ -1460,7 +1530,12 @@ See sidebar for more commands to try.
nil)
(defmethod special-collision ((self node)) nil)
;; Layout:1 ends here
;; Duplicating a node :ccl:sbcl:
;; [[file:~/xelf/gui.org::*Duplicating%20a%20node][Duplicating a node:1]]
(defmethod duplicate ((node node) &rest initargs &key &allow-other-keys)
(let* ((class (class-of node))
(new-node (allocate-instance class)))
......@@ -1478,7 +1553,12 @@ See sidebar for more commands to try.
(setf (slot-value new-node slot-name) (slot-value node slot-name))))
;; (setf (uuid node) nil) ;; needs a new UUID during init
(apply #'reinitialize-instance new-node initargs)))))
;; Duplicating a node:1 ends here
;; Phrase class
;; [[file:~/xelf/gui.org::*Phrase%20class][Phrase class:1]]
(defclass phrase (node)
((spacing :initform 1)
(dash :initform 2)
......@@ -1498,7 +1578,12 @@ See sidebar for more commands to try.
(mapcar #'recompile (slot-value self 'inputs)))
(defparameter *null-display-string* " ")
;; Phrase class:1 ends here
;; Manipulability
;; [[file:~/xelf/gui.org::*Manipulability][Manipulability:1]]
(defmethod frozenp ((self phrase))
(slot-value self 'frozen))
......@@ -1509,7 +1594,12 @@ See sidebar for more commands to try.
(defmethod unfreeze ((self phrase))
(setf (slot-value self 'frozen) nil)
(mapc #'unpin (mapcar #'find-object (slot-value self 'inputs))))
;; Manipulability:1 ends here
;; Orientation
;; [[file:~/xelf/gui.org::*Orientation][Orientation:1]]
(defmethod set-orientation ((self phrase) orientation)
(assert (member orientation '(:horizontal :vertical)))
(setf (slot-value self 'orientation) orientation))
......@@ -1519,7 +1609,12 @@ See sidebar for more commands to try.
(ecase (slot-value self 'orientation)
(:horizontal :vertical)
(:vertical :horizontal))))
;; Orientation:1 ends here
;; Inputs
;; [[file:~/xelf/gui.org::*Inputs][Inputs:1]]
(defmethod can-accept ((self phrase))
(not (slot-value self 'frozen)))
......@@ -1557,7 +1652,9 @@ See sidebar for more commands to try.
(progn
(setf inputs (list input))
(set-parent (find-object input) self)))))))
;; Inputs:1 ends here
;; [[file:~/xelf/gui.org::*Inputs][Inputs:2]]
(defmethod take-first ((self phrase))
(with-slots (inputs) self
(let ((block (first inputs)))
......@@ -1566,7 +1663,12 @@ See sidebar for more commands to try.
(defmethod get-length ((self phrase))
(length (slot-value self 'inputs)))
;; Inputs:2 ends here
;; Layout
;; [[file:~/xelf/gui.org::*Layout][Layout:1]]
(defmethod header-height ((self phrase)) 0)
(defmethod label-width ((self phrase)) 0)
......@@ -1644,7 +1746,12 @@ See sidebar for more commands to try.
(defmacro defphrase (name &rest body)
`(defclass ,name (phrase) ,@body))
;; Layout:1 ends here
;; Phrase / S-expression correspondence
;; [[file:~/xelf/gui.org::*Phrase%20/%20S-expression%20correspondence][Phrase / S-expression correspondence:1]]
(defun make-sentence (contents)
(let ((phrase (apply #'new 'phrase :inputs (list contents))))
(prog1 phrase
......@@ -1697,7 +1804,12 @@ See sidebar for more commands to try.
(defun duplicate-phrase (phrase)
(make-phrase (compile-phrase phrase)))
;; Phrase / S-expression correspondence:1 ends here
;; Data entry and validation
;; [[file:~/xelf/gui.org::*Data%20entry%20and%20validation][Data entry and validation:1]]
(defclass entry (prompt)
((old-line :initform nil)
(tags :initform '(:word))
......@@ -1984,7 +2096,12 @@ See sidebar for more commands to try.
(when (stringp value)
(setf (slot-value self 'value) value)
(setf (slot-value self 'line) value)))
;; Data entry and validation:1 ends here
;; Multiline text edit control
;; [[file:~/xelf/gui.org::*Multiline%20text%20edit%20control][Multiline text edit control:1]]
(defparameter *text-margin* (dash 2) "Default onscreen margin (in pixels) of a text.")
(defparameter *text-minimum-width* 80)
......@@ -2349,7 +2466,12 @@ See sidebar for more commands to try.
;; :blink t))))))
(defmethod draw-hover ((self text)) nil)
;; Multiline text edit control:1 ends here
;; Tree browser widget
;; [[file:~/xelf/gui.org::*Tree%20browser%20widget][Tree browser widget:1]]
;;; Trees
(defvar *tree-depth* 0)
......@@ -2585,7 +2707,12 @@ See sidebar for more commands to try.
(mapcar #'xform item)))
item)))
(xform items)))
;; Tree browser widget:1 ends here
;; Menu widget
;; [[file:~/xelf/gui.org::*Menu%20widget][Menu widget:1]]
(defclass menu (tree)
((action :initform nil)
(always-visible :initform t)
......@@ -2731,3 +2858,4 @@ See sidebar for more commands to try.
(when (and (< left x right)
(< top y bottom))
(draw-highlight self)))))))
;; Menu widget:1 ends here
#+TITLE: Xelf: The Graphical User Interface Toolkit
#+AUTHOR: David O'Toole <dto@xelf.me>
#+OPTIONS: toc:3 *:nil
#+PROPERTY: header-args:lisp :results silent :noweb no :tangle gui.lisp :package "xelf"
#+PROPERTY: header-args:lisp :results silent :noweb no :tangle gui.lisp :package "xelf" :comments both
#+INFOJS_OPT: view:info mouse:underline up:xelf.html home:http://xelf.me toc:t ftoc:t ltoc:t
# (setq org-confirm-babel-evaluate nil)
......@@ -2880,7 +2880,7 @@ hybrid GUI inspired by MIT Scratch and its derivatives.
(draw-highlight self)))))))
#+end_src
* Command shell (shell.lisp)
* Shell workspace (shell.lisp)
#+begin_src lisp :tangle shell.lisp
(in-package :xelf)
......@@ -3115,7 +3115,7 @@ hybrid GUI inspired by MIT Scratch and its derivatives.
(setf *shell* (make-instance 'shell))))
#+end_src
** Shell commands
** Captions and labels
#+begin_src lisp :tangle commands.lisp
(in-package :xelf)
......@@ -3153,6 +3153,8 @@ hybrid GUI inspired by MIT Scratch and its derivatives.
(draw-caption-string self (fancy-format-expression expression)))
#+end_src
** Shell operations
#+begin_src lisp :tangle commands.lisp
(defmethod drag ((self shell) x y)
(with-slots (target-x target-y) self
......@@ -3375,7 +3377,7 @@ hybrid GUI inspired by MIT Scratch and its derivatives.
(exit-xelf))
#+end_src
** User Commands
** User dialogs
#+begin_src lisp :tangle commands.lisp
(define-dialog rename-buffer-dialog
......@@ -3750,7 +3752,7 @@ hybrid GUI inspired by MIT Scratch and its derivatives.
(defmethod execute ((command command))
(setf (undo-action command)
(make-undo-action command))
(apply (function (action command))
(apply (symbol-function (action command))
(cons (target command)
(data command)))
(setf (executed-p command) t))
......
;; Command shell (shell.lisp)
;; [[file:~/xelf/gui.org::*Command%20shell%20(shell.lisp)][Command shell (shell.lisp):1]]
(in-package :xelf)
;; Command shell (shell.lisp):1 ends here
;; Messenger widget
;; [[file:~/xelf/gui.org::*Messenger%20widget][Messenger widget:1]]
(defclass messenger (node)
((category :initform :terminal)
(messages :initform nil)))
......@@ -50,7 +59,12 @@
:color *messenger-color*
:font *block-font*)
(decf y0 (font-height *font*)))))))
;; Messenger widget:1 ends here