/[cello]/cello/ctl-markbox.lisp
ViewVC logotype

Contents of /cello/ctl-markbox.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.13 - (show annotations)
Fri Apr 11 09:22:47 2008 UTC (6 years ago) by ktilton
Branch: MAIN
CVS Tags: HEAD
Changes since 1.12: +29 -28 lines
*** empty log message ***
1 ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cello; -*-
2 #|
3
4 Copyright (C) 2004 by Kenneth William Tilton
5
6 This library is free software; you can redistribute it and/or
7 modify it under the terms of the Lisp Lesser GNU Public License
8 (http://opensource.franz.com/preamble.html), known as the LLGPL.
9
10 This library is distributed WITHOUT ANY WARRANTY; without even
11 the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
12
13 See the Lisp Lesser GNU Public License for more details.
14
15 |#
16
17 (in-package :cello)
18
19 (defparameter *mark-box-size* (u96ths 9))
20
21 (eval-now!
22 (defmethod ix-layer-expand ((self (eql :x-mark)) &rest args)
23 `(ix-render-x-mark ,(car args) l-box ,(second args) ,(third args))))
24
25 (defmd ct-mark-box (ct-toggle ix-view)
26 :ll (- *mark-box-size*)
27 :lt (ups *mark-box-size*)
28 :lr *mark-box-size*
29 :lb (downs *mark-box-size*)
30 :skin nil ;;(c? (skin .w.))
31 :pre-layer (with-layers
32 (:in 4)
33 +light-gray+ ;;;(if (^enabled) +white+ +gray+)
34 :off
35 (:frame-3d :edge-sunken :thickness 4)
36 :off
37 (:rgba (or (^fg-color) +black+))
38 (:out 4)
39 (:x-mark (^value))))
40
41 (defun ix-render-x-mark (do-p lbox &optional thickness inset
42 &aux (thick (or thickness (/ (r-width lbox) 4)))
43 (ins (or inset thick)))
44 (when do-p
45 (let* ((br (- (r-right lbox) ins)) ;; /// bogus use of thick to inset "x"
46 (bl (+ (r-left lbox) ins))
47 (bt (+ (r-top lbox) (downs ins)))
48 (bb (+ (r-bottom lbox) (ups ins))))
49 (with-matrix ()
50 (gl-line-width (log2scr thick))
51 (gl-disable gl_texture_2d)
52 (with-gl-begun (gl_lines)
53 (gl-vertex3f bl bt 0)(gl-vertex3f br bb 0)
54 (gl-vertex3f bl bb 0)(gl-vertex3f br bt 0))
55 (ogl::glec :f3d)))))
56
57 ; ----- radios -------------------------------
58
59 (defmodel ct-radio-item (ct-toggle)
60 ((kb-selector :cell nil :initarg :kb-selector :initform nil :reader kb-selector)
61 (already-on-do :cell nil :initarg :already-on-do :initform nil :reader already-on-do)
62 (radio :initarg :radio :accessor radio :initform (c? (upper self ct-radio))))
63 (:default-initargs
64 :enabled t
65 :value (c? (find (associated-value self) (value (^radio))))
66 :ct-action (ct-action-lambda
67 (with-cc :ct-radio-item
68 (radio-item-to-value self event (^radio))))))
69
70
71 (defun radio-item-to-value (self event radio)
72 (declare (ignorable event))
73 (trc nil "radio item acts" self (value self) (already-on-do self) .w.)
74 (if (value self)
75 (ecase (already-on-do self)
76 ((nil))
77 (:off (setf (value radio) nil)))
78 (progn
79 (trc nil "here come rb" (associated-value self) radio)
80 (setf (value radio)
81 (list (associated-value self))))))
82
83 (defmodel ct-radio-button (ct-mark-box ct-radio-item) ())
84 (defmodel ct-text-radio-item ( ct-radio-item ct-text)())
85
86 (defmd ct-text-selectable (ct-selectable ct-text))
87
88 (defmd ct-radio (control ix-inline)
89 on-change
90 :value (c-in nil))
91
92 (defobserver .value ((self ct-radio)) ;; /// should every control have this?
93 (when (^on-change)
94 ;(trcx radio-value-observer self new-value old-value old-value-boundp)
95 (funcall (^on-change) self new-value old-value old-value-boundp)))
96
97 (defmodel ct-radio-row (ct-radio)
98 ()
99 (:default-initargs
100 :orientation :horizontal
101 :value (c-in nil)))
102
103 (defmodel ct-radio-stack (ct-radio)
104 ()
105 (:default-initargs
106 :value (c-in nil)
107 :orientation :vertical))
108
109 (defun radio-on-name (radio-values)
110 (some (lambda (rb-value)
111 (unless (empty$ (cdr rb-value))
112 (car rb-value)))
113 radio-values))
114
115 ;--------------- CTCheckBox --------------------------------------------
116 (export! ct-check-box ct-check-text ct-radio-labeled ct-radio-push-button ct-text-selectable)
117
118 (defmodel ct-check-box (ct-mark-box)
119 ()
120 (:default-initargs
121 :lighting :on
122 :value (c-in nil))
123 )
124
125 (defmd ct-check-text (control ix-row)
126 :value (c-in nil)
127 :justify :center
128 :spacing (u96ths 8)
129 :outset (u96ths 2)
130 :kids (c? (the-kids
131 (make-kid 'ct-check-box
132 :md-name :check-box
133 :fg-color (c? (fg-color .parent))
134 :value (c? (value .parent))
135 :enabled nil) ;; let parent handle clicks since text is clickable by the rules
136 (make-kid 'ix-text
137 :md-name :label
138 :text$ (c? (title$ .parent))
139 :style-id :button)))
140
141 :ct-action (ct-action-lambda
142 (trc nil "checktext bingo" (not (value self)))
143 (with-cc :check-text-action
144 (setf (value self) (not (value self))))))
145
146 (defmodel ct-radio-labeled (ix-row ct-radio-item)
147 ()
148 (:default-initargs
149 :justify :center
150 :spacing (u96ths 8)
151 :outset (u96ths 2)
152 :kids (c? (the-kids
153 (mk-part :rbutton (ct-check-box)
154 :value (c? (value .parent))
155 :enabled nil) ;; let parent handle clicks since text is clickable by the rules
156
157 (mk-part :label (ix-text)
158 :lighting :off
159 :text$ (c? (title$ .parent))
160 :style-id :button
161 :text-color (c? (if (enabled .parent)
162 +white+ +gray+))
163 :pre-layer (with-layers (:rgba (^text-color))))))))
164
165 (defmodel ct-radio-push-button (ct-radio-item ct-button)
166 ()
167 (:default-initargs
168 :inset (mkv2 (upts 4) (upts 4))
169 :depressed (c? (or (^hilited)(^value)))
170 ))
171
172 (defmethod ix-paint ((self ct-radio-push-button))
173 (when (eql self (kid1 .parent))
174 (trc nil "rendering radio-push" self :raster (ogl-raster-pos-get))
175 #+(or) (if (ogl-is-enabled gl_scissor_test)
176 (trc "rendering radio-push" self :scissored (ogl-bounds (ogl-scissor-box)))
177 (trc "rendering radio-push" :unscissored)))
178 (call-next-method))
179
180 (defmodel ct-push-toggle (ct-toggle ct-button)
181 ()
182 (:default-initargs
183 :value (c-in nil)))
184
185 (export! ct-dot-grid)
186 (defmd ct-dot-grid (control ix-dot-grid))

  ViewVC Help
Powered by ViewVC 1.1.5