Changeset main,47

Timestamp:

11/12/2007 08:45:41 PM (19 years ago)

Author:

David Owen <dsowen@…>

branch-nick:

tui

revision id:

dsowen@tux-20071112204541-jhhqab8g511tp3xv

Message:

Added color to forms.

Location:

main

Files:

• form-test.lisp (modified) (1 diff)
• form.lisp (modified) (4 diffs)

main/form-test.lisp

@@ -7 +7 @@
 
 
-(defform test ((:label 0 0 "Family name:")
-               (:textbox 0 13 family-name 16)
-               (:label 1 0 " Given name:")
-               (:textbox 1 13 given-name 16)
-               (:label 2 0 "        Age:")
-               (:numberbox 2 13 age 2)))
+(defform test (:inactive-widget-background (#\Space 60)
+               :active-widget-background (#\Space 57))
+  (:label 0 0 "Family name:")
+  (:textbox 0 13 family-name 16
+            :inactive-background (#\Space 6)
+            :active-background (#\Space 3))
+  (:label 1 0 " Given name:")
+  (:textbox 1 13 given-name 16)
+  (:label 2 0 "        Age:")
+  (:numberbox 2 13 age 2))
 
 (defclass test ()

main/form.lisp

@@ -31 +31 @@
 (defclass textbox-def (value-widget-def)
   ((display-width :initarg :display-width)
-   (data-width :initarg :data-width)))
+   (data-width :initarg :data-width)
+   (inactive-background :initarg :inactive-background)
+   (active-background :initarg :active-background)))
 
 (defclass numberbox-def (value-widget-def)
   ((display-width :initarg :display-width)
    (data-width :initarg :data-width)
-   (precision :initarg :precision)))
+   (precision :initarg :precision)
+   (inactive-background :initarg :inactive-background)
+   (active-background :initarg :active-background)))
 
 (defclass form-def ()
@@ -43 +47 @@
 
 
+(defvar *default-inactive-widget-background*)
+(defvar *default-active-widget-background*)
+
 (defun make-label-def (row column text)
   `(make-instance 'label-def :row ,row :column ,column :text ,text))
 
 (defun make-textbox-def (row column name display-width
-                         &key data-width read-only)
+                         &key data-width read-only
+                         (inactive-background
+                          *default-inactive-widget-background*)
+                         (active-background
+                          *default-active-widget-background*))
   `(make-instance 'textbox-def
                   :row ,row :column ,column :name ',name
                   :display-width ,display-width :data-width ,data-width
-                  :read-only ,read-only))
+                  :read-only ,read-only
+                  :inactive-background ',inactive-background
+                  :active-background ',active-background))
 
 (defun make-numberbox-def (row column name display-width
-                           &key data-width precision read-only)
+                           &key data-width precision read-only
+                           (inactive-background
+                            *default-inactive-widget-background*)
+                           (active-background
+                            *default-active-widget-background*))
   `(make-instance 'numberbox-def
                   :row ,row :column ,column :name ',name
                   :display-width ,display-width :data-width ,data-width
-                  :precision ,precision :read-only ,read-only))
+                  :precision ,precision :read-only ,read-only
+                  :inactive-background ',inactive-background
+                  :active-background ',active-background))
 
 (defun parse-widget-form (widget-form)
@@ -70 +89 @@
 (defvar *form-definitions* (make-hash-table :test #'eq ))
 
-(defmacro defform (name (&body widgets))
+(defmacro defform (name (&rest options) &body widgets)
   "Each widget is one of:
 - (:label row column text)
 - (:textbox row column name display-width &key data-width read-only)
 - (:numberbox row column name display-width &key data-width precision read-only)"
-  (with-gensyms (elements)
-    `(let ((,elements (list ,@(mapcar 'parse-widget-form widgets))))
-       (setf (gethash ',name *form-definitions*)
-             (make-instance 'form-def :elements (coerce ,elements 'vector))))))
-
+  (destructuring-bind (&key ((:inactive-widget-background *default-inactive-widget-background*) '(#\Space 0))
+                            ((:active-widget-background *default-active-widget-background*) '(#\Space 0)))
+      options
+    (with-gensyms (elements)
+      `(let ((,elements (vector ,@(mapcar 'parse-widget-form widgets))))
+         (setf (gethash ',name *form-definitions*)
+               (make-instance 'form-def :elements ,elements))))))
 
 
@@ -105 +126 @@
         (create-label window row column text))))
   (:method ((tbd textbox-def) form)
-    (with-slots (row column name display-width) tbd
+    (with-slots (row column name display-width inactive-background
+                     active-background) tbd
       (with-slots (data window scroll) form
         (let ((r (make-reflector data name)))
-          (create-textbox window (- row scroll) column r display-width)))))
+          (create-textbox window (- row scroll) column r display-width
+                          :inactive-background inactive-background
+                          :active-background active-background)))))
   (:method ((nbd numberbox-def) form)
-    (with-slots (row column name display-width) nbd
+    (with-slots (row column name display-width inactive-background
+                     active-background) nbd
       (with-slots (data window scroll) form
         (let ((r (make-reflector data name)))
-          (create-numberbox window (- row scroll) column r display-width))))))
+          (create-numberbox window (- row scroll) column r display-width
+                            :inactive-background inactive-background
+                            :active-background active-background))))))