Examples on data classes. remap-data. Extending accessor-data.

components/combo.lisp

@@ -3,6 +3,9 @@
 (defclass combo-item (button direct-value-component)
   ())
 
+(defclass combo-item* (combo-item)
+  ((text :initarg :text :initform NIL :accessor text)))
+
 (defclass combo-layout (vertical-linear-layout)
   ((parent :initarg :parent :accessor parent)))
 
@@ -62,7 +65,10 @@
 (defmethod text ((combo combo))
   (if (focused combo)
       (text (focused combo))
-      (princ-to-string (value combo))))
+      (let ((value (value combo)))
+        (do-elements (element combo :result (princ-to-string value))
+          (when (eql value (value element))
+            (return (text element)))))))
 
 (defmethod notice-size ((list combo-layout) (combo combo))
   (notice-size combo T))
@@ -190,3 +196,6 @@
 
 (defmethod (setf value-set) :after (set (combo combo-set))
   (update-combo-items combo set))
+
+(defmethod combo-item ((item cons) (combo combo-set))
+  (make-instance 'combo-item* :value (car item) :text (cdr item)))

data.lisp

@@ -109,13 +109,33 @@
   (let ((table (make-hash-table :test 'eql)))
     (setf (mapping data) table)))
 
+(defmethod (setf c2mop:slot-value-using-class) :around (value class (data remap-data) slot)
+  (let ((mapped (when (slot-boundp data 'mapping)
+                  (gethash (c2mop:slot-definition-name slot) (mapping data)))))
+    (if mapped
+        (setf (slot-value (object data) mapped) value)
+        (call-next-method))))
+
+(defmethod access ((data remap-data) field)
+  (let ((mapped (gethash field (mapping data))))
+    (if mapped
+        (access (object data) mapped)
+        (slot-value data field))))
+
+(defmethod (setf access) (value (data remap-data) field)
+  (let ((mapped (gethash field (mapping data))))
+    (if mapped
+        (setf (access (object data) mapped) value)
+        (setf (slot-value data field) value))))
+
 (defmethod observe ((nothing (eql NIL)) object (data remap-data) &optional (name data))
-  (loop for function being the hash-keys of (observed data)
-        do (remove-observers function object name)))
+  (loop for mapped being the hash-value of (mapping data)
+        do (remove-observers mapped object name)))
 
 (defmethod observe ((all (eql T)) object (data remap-data) &optional (name data))
-  (loop for function being the hash-keys of (observed data) using (hash-value mapped)
-        do (observe function object (lambda (&rest args) (apply #'notify-observers mapped data args)) name))
+  (loop for function being the hash-keys of (mapping data) using (hash-value mapped)
+        do (let ((mapped mapped) (function function))
+             (observe mapped object (lambda (&rest args) (apply #'notify-observers function data args)) name)))
   (refresh data))
 
 (defmethod refresh ((data remap-data))
@@ -155,6 +175,12 @@
   ((accessor :initarg :accessor :initform (arg! :accessor) :accessor accessor)))
 
 (defmethod initialize-instance :after ((data accessor-data) &key)
+  (when (typep (object data) 'observable-object)
+    (let* ((generic (c2mop:ensure-generic-function (accessor data)))
+           (method (car (c2mop:generic-function-methods generic)))
+           (slot (c2mop:accessor-method-slot-definition method)))
+      (observe (c2mop:slot-definition-name slot) (object data) (lambda (value object) (notify-observers 'value data value object)) data)))
+
   (when (typep (object data) 'observable)
     (observe (accessor data) (object data) (lambda (value object) (notify-observers 'value data value object)) data)))
 

examples/alloy-examples.asd

@@ -16,6 +16,7 @@
                (:file "font-mixing")
                (:file "fonts")
                (:file "canvas")
-	       (:file "gradient"))
+	       (:file "gradient")
+	       (:file "data"))
   :depends-on (:alloy-glfw
                :alloy-constraint))

examples/data.lisp

@@ -0,0 +1,125 @@
+(in-package #:org.shirakumo.alloy.examples)
+
+(defclass example-object (alloy:observable-object)
+  ((foo :initform "foo")
+   (bar :initform "bar" :accessor bar-accessor)))
+
+(defclass another-object (alloy:observable-object alloy:remap-data)
+  ((far) (boo :accessor boo-accessor)
+   (unique :initform "unique")))
+
+(define-example data (screen)
+  (let* ((window      (windowing:make-window screen))
+	 (object      (make-instance 'example-object))
+	 (object-data (make-instance 'alloy:object-data :object object))
+	 ;; Mapping makes it so that a slot in the new object is mapped to the slot of the base object
+	 (remap-data (make-instance 'another-object :object object :mapping (mk-hash-table 'far 'foo 'boo 'bar)))
+         (layout     (make-instance 'alloy:vertical-linear-layout :layout-parent window))
+         (focus      (make-instance 'alloy:focus-list :focus-parent window))
+	 (refresh    (alloy:represent "Refresh" 'alloy:button :layout-parent layout :focus-parent focus))
+	 (adjust-1   (alloy:represent "(slot-value object 'bar)" 'alloy:button))
+	 (adjust-2   (alloy:represent "(slot-value object 'foo)" 'alloy:button)))
+
+    (alloy:on alloy:activate (refresh) (alloy:refresh layout))
+    (alloy:on alloy:activate (adjust-1) (setf (slot-value object 'bar) (randobar)))
+    (alloy:on alloy:activate (adjust-2) (setf (slot-value object 'foo) (randofoo)))
+
+    (alloy:enter-all layout adjust-1 adjust-2)
+    (alloy:enter-all focus adjust-1 adjust-2)
+
+    ;; Shows an interaction with the accessor-data class
+    (let* ((layout            (make-instance 'alloy:horizontal-linear-layout :layout-parent layout))
+	   (bar-accessor-data (make-instance 'alloy:accessor-data :accessor 'bar-accessor :object object))
+	   (label             (make-instance 'alloy:label :data bar-accessor-data))
+	   (button            (alloy:represent "(alloy:value bar-accessor-data)" 'alloy:button)))
+      (alloy:on alloy:activate (button) (setf (alloy:value bar-accessor-data) (randobar)))
+      (alloy:enter-all layout button label)
+      (alloy:enter-all focus button))
+
+    ;; Shows an interaction with the slot-data class
+    (let* ((layout        (make-instance 'alloy:horizontal-linear-layout :layout-parent layout))
+	   (foo-slot-data (make-instance 'alloy:slot-data :slot 'foo :object object))
+	   (label         (make-instance 'alloy:label :data foo-slot-data))
+	   (button        (alloy:represent "(alloy:value foo-slot-data)" 'alloy:button)))
+      (alloy:on alloy:activate (button) (setf (alloy:value foo-slot-data) (randofoo)))
+      (alloy:enter-all layout button label)
+      (alloy:enter-all focus button))
+
+    ;; Object-data but label is accessing the bar field of the object
+    (let* ((layout (make-instance 'alloy:horizontal-linear-layout :layout-parent layout))
+	   (label  (make-instance 'alloy:label :data object-data :value-function 'bar))
+	   (button (alloy:represent "(access object-data 'bar)" 'alloy:button)))
+      (alloy:on alloy:activate (button) (setf (alloy:access object-data 'bar) (randobar)))
+      (alloy:enter-all layout button label)
+      (alloy:enter-all focus button))
+
+    ;; Object-data but label is accessing the foo field of the object
+    (let* ((layout (make-instance 'alloy:horizontal-linear-layout :layout-parent layout))
+	   (label  (make-instance 'alloy:label :data object-data :value-function 'foo))
+	   (button (alloy:represent "(access object-data 'foo)" 'alloy:button)))
+      (alloy:on alloy:activate (button) (setf (alloy:access object-data 'foo) (randofoo)))
+      (alloy:enter-all layout button label)
+      (alloy:enter-all focus button))
+
+    ;; Using an object with remapped-data targeting boo->bar
+    (let* ((layout   (make-instance 'alloy:horizontal-linear-layout :layout-parent layout))
+	   (label    (make-instance 'alloy:label :data remap-data :value-function 'boo))
+	   (button   (alloy:represent "(alloy:access remap-data 'boo)" 'alloy:button))
+	   (button-2 (alloy:represent "(slot-value remap-data 'boo)" 'alloy:button)))
+      (alloy:on alloy:activate (button) (setf (alloy:access remap-data 'boo) (randoboo)))
+      (alloy:on alloy:activate (button-2) (setf (slot-value remap-data 'boo) (randoboo)))
+      (alloy:enter-all layout button button-2 label)
+      (alloy:enter-all focus button button-2 ))
+
+    ;; Using an object with remapped-data targeting far-foo
+    (let* ((layout   (make-instance 'alloy:horizontal-linear-layout :layout-parent layout))
+	   (label    (make-instance 'alloy:label :data remap-data :value-function 'far))
+	   (button   (alloy:represent "(alloy:access remap-data 'far)" 'alloy:button))
+	   (button-2 (alloy:represent "(slot-value remap-data 'far)" 'alloy:button)))
+      (alloy:on alloy:activate (button) (setf (alloy:access remap-data 'far) (randofar)))
+      (alloy:on alloy:activate (button-2) (setf (slot-value remap-data 'far) (randofar)))
+      (alloy:enter-all layout button button-2 label)
+      (alloy:enter-all focus button button-2))
+
+    ;; Using remap-data but with a slot that is not mapped
+    (let* ((layout (make-instance 'alloy:horizontal-linear-layout :layout-parent layout))
+	   (label  (make-instance 'alloy:label :data remap-data :value-function 'unique))
+	   (button (alloy:represent "(alloy:access remap-data 'unique)" 'alloy:button)))
+      (alloy:on alloy:activate (button) (setf (alloy:access remap-data 'unique) (randounique)))
+      (alloy:enter-all layout button label)
+      (alloy:enter-all focus button))
+
+    ;; Attaches observers that will print out the observation
+    ;; e.g: (alloy:observe 'boo remap-data (lambda (value data) (print "Observation")))
+    (loop for (observation observable) in `((foo ,object) (bar ,object) (foo ,object-data) (bar ,object-data)
+					    (unique ,remap-data) (boo ,remap-data) (far ,remap-data))
+	  do (let ((observation observation) (observable observable))
+	       (alloy:observe observation observable
+			      (lambda (value data)
+				(declare (ignore value data))
+				(format t "Observed a change for ~a in ~a~%" observation observable)))))))
+
+
+(presentations:define-update (presentations:default-look-and-feel alloy:button)
+  (:label :text alloy:text
+   :halign :start
+   :size 10))
+
+(presentations:define-update (presentations:default-look-and-feel alloy:label)
+  (:label :text alloy:text
+   :halign :start
+   :size 10))
+
+
+;; Convenience utilities
+(defun randofoo () (format nil "foo-~a" (random 1000)))
+(defun randobar () (format nil "bar-~a" (random 1000)))
+(defun randofar () (format nil "far-~a" (random 1000)))
+(defun randoboo () (format nil "boo-~a" (random 1000)))
+(defun randounique () (format nil "unique-~a" (random 1000)))
+
+(defun mk-hash-table (&rest args)
+  (let ((table (make-hash-table :test 'eql)))
+    (loop for (key value) on args by #'cddr
+	  collect (setf (gethash key table) value))
+    table))