[cello-cvs] CVS cello
ktilton
ktilton at common-lisp.net
Mon Nov 13 05:29:27 UTC 2006
Update of /project/cello/cvsroot/cello
In directory clnet:/tmp/cvs-serv11178
Modified Files:
application.lisp cello-openal.lisp cello-window.lisp cello.lpr
control.lisp ctl-markbox.lisp ctl-toggle.lisp
focus-utilities.lisp focus.lisp ix-grid.lisp ix-togl.lisp
Log Message:
--- /project/cello/cvsroot/cello/application.lisp 2006/10/13 08:04:45 1.8
+++ /project/cello/cvsroot/cello/application.lisp 2006/11/13 05:29:26 1.9
@@ -34,7 +34,7 @@
(cl-ftgl-reset) ;; 2006-09-27 back in temporarily ...
;; new 2006-08-28: in face of weird OGL 1282 when
;; new chars hit in ratios
-
+ (mgk::wands-clear)
;; Init global *sys* ... needed for Cello context ops
(when system-type
(setf *sys* (make-instance system-type :md-name 'mgsys)))
--- /project/cello/cvsroot/cello/cello-openal.lisp 2006/07/06 22:09:10 1.4
+++ /project/cello/cvsroot/cello/cello-openal.lisp 2006/11/13 05:29:26 1.5
@@ -18,6 +18,8 @@
(defstruct sound paths (gain 1) callback loopingp start (source :default) buffer sources)
+(export! make-sound ix-sound-install ix-play-start)
+
(defun ix-sound-install (self sound)
(when (and sound (cl-openal-init))
(ix-play-start self sound)
@@ -72,11 +74,16 @@
(pathname (make-sound :paths (list (merge-pathnames sound-spec
oal::*audio-files*))))))
+(merge-pathnames (make-pathname :directory '(:relative "mistakes"))
+ oal::*audio-files*)
+
(defun ix-sound-spec-find (self key)
(when (typep self 'ix-view)
(or (cdr (assoc key (sound self)))
(ix-sound-spec-find .parent key))))
+(export! sound-manager sounds sources)
+
(defmodel sound-manager ()
((sources :initarg :sources :accessor sources
:initform (list (cons :default (car (al-source-gen 1)))))
--- /project/cello/cvsroot/cello/cello-window.lisp 2006/10/17 21:30:08 1.6
+++ /project/cello/cvsroot/cello/cello-window.lisp 2006/11/13 05:29:26 1.7
@@ -59,7 +59,7 @@
(:MotionNotify (trc "we got motion!!!!"))
(:EnterNotify )
(:LeaveNotify )
- (:FocusIn )
+ (:FocusIn (TRC "cello-window-event-handler" self (ctk::tk-event-type (ctk::xsv type xe)) ))
(:FocusOut )
(:KeymapNotify )
(:Expose )
--- /project/cello/cvsroot/cello/cello.lpr 2006/11/04 20:56:30 1.15
+++ /project/cello/cvsroot/cello/cello.lpr 2006/11/13 05:29:26 1.16
@@ -1,4 +1,4 @@
-;; -*- lisp-version: "8.0 [Windows] (Oct 17, 2006 12:56)"; cg: "1.81"; -*-
+;; -*- lisp-version: "8.0 [Windows] (Nov 6, 2006 16:43)"; cg: "1.81"; -*-
(in-package :cg-user)
--- /project/cello/cvsroot/cello/control.lisp 2006/10/28 18:22:43 1.7
+++ /project/cello/cvsroot/cello/control.lisp 2006/11/13 05:29:26 1.8
@@ -20,6 +20,7 @@
(title$ (c? (format nil "~:(~a~)" ;; this is just a poor default-- really s.b. supplied by form author
(string-downcase (substitute #\space #\- (string (md-name self)))))))
(ct-action nil :cell nil)
+ sound
click-repeat-p
(click-repeat-event (c? (bwhen (c (^click-evt))
(let ((age (f-sensitivity :age (0.1)
@@ -36,6 +37,8 @@
(kb-selector nil :cell nil)
:gl-name (c? (incf (gl-name-highest .w.))))
+(defmethod kb-selector (other) (declare (ignore other)) nil)
+
(defobserver click-repeat-event ()
(with-integrity (:change :obs-click-repeat-event)
(when new-value
--- /project/cello/cvsroot/cello/ctl-markbox.lisp 2006/11/04 20:56:30 1.10
+++ /project/cello/cvsroot/cello/ctl-markbox.lisp 2006/11/13 05:29:26 1.11
@@ -22,24 +22,21 @@
(defmethod ix-layer-expand ((self (eql :x-mark)) &rest args)
`(ix-render-x-mark ,(car args) l-box ,(cadr args))))
-(defmodel ct-mark-box (ct-toggle ix-view)
- ((kb-selector :cell nil :initarg :kb-selector :initform nil :reader kb-selector)
- )
- (:default-initargs
- :ll (- *mark-box-size*)
- :lt (ups *mark-box-size*)
- :lr *mark-box-size*
- :lb (downs *mark-box-size*)
- :skin nil ;;(c? (skin .w.))
- :pre-layer (with-layers
- (:in 4)
- +light-gray+ ;;;(if (^enabled) +white+ +gray+)
- :off
- (:frame-3d :edge-sunken :thickness 4)
- :off
- +dark-gray+
- (:out 4)
- (:x-mark (^value)))))
+(defmd ct-mark-box (ct-toggle ix-view)
+ :ll (- *mark-box-size*)
+ :lt (ups *mark-box-size*)
+ :lr *mark-box-size*
+ :lb (downs *mark-box-size*)
+ :skin nil ;;(c? (skin .w.))
+ :pre-layer (with-layers
+ (:in 4)
+ +light-gray+ ;;;(if (^enabled) +white+ +gray+)
+ :off
+ (:frame-3d :edge-sunken :thickness 4)
+ :off
+ +dark-gray+
+ (:out 4)
+ (:x-mark (^value))))
(defun ix-render-x-mark (do-p lbox &optional thickness &aux (thick (or thickness (/ (r-width lbox) 4))))
(when do-p
@@ -67,7 +64,7 @@
:enabled t
:value (c? (find (associated-value self) (value (^radio))))
:ct-action (lambda (self event)
- (with-c-change :ct-radio-item
+ (with-cc :ct-radio-item
(radio-item-to-value self event (^radio))))))
@@ -92,7 +89,7 @@
(defobserver .value ((self ct-radio)) ;; /// should every control have this?
(when (^on-change)
- (trcx nil radio-value-observer self new-value old-value old-value-boundp)
+ (trcx radio-value-observer self new-value old-value old-value-boundp)
(funcall (^on-change) self new-value old-value old-value-boundp)))
(defmodel ct-radio-row (ct-radio)
@@ -143,7 +140,7 @@
:ct-action (lambda (self event)
(declare (ignorable event))
(trc nil "checktext bingo" (not (value self)))
- (with-c-change :check-text-action
+ (with-cc :check-text-action
(setf (value self) (not (value self)))))))
(defmodel ct-radio-labeled (ix-row ct-radio-item)
@@ -184,3 +181,6 @@
()
(:default-initargs
:value (c-in nil)))
+
+(export! ct-dot-grid)
+(defmd ct-dot-grid (control ix-dot-grid))
\ No newline at end of file
--- /project/cello/cvsroot/cello/ctl-toggle.lisp 2006/11/04 20:56:30 1.9
+++ /project/cello/cvsroot/cello/ctl-toggle.lisp 2006/11/13 05:29:26 1.10
@@ -32,6 +32,8 @@
:pre-layer (with-layers :off +white+
:fill (:rgba (^text-color)))))
+(export! ix-control ct-action kb-selector)
+(defmd ix-control (ix-view control))
(defmd ct-button (control ix-text) ;; same inheritance, but otherwise unrelated to CTText
(value (c-in nil) :cell :ephemeral)
@@ -39,7 +41,7 @@
(depressed (c? (^hilited)))
:ct-action (lambda (self event)
(declare (ignore event))
- (with-c-change :button-press
+ (with-cc :button-press
.retog.
(setf (^value) t)))
:title$ (c? (string-capitalize (md-name self)))
@@ -89,7 +91,7 @@
:title$ ,text
:ct-action (lambda (self event)
(declare (ignorable self event))
- (with-c-change :ct-button-ex-ct-action
+ (with-cc :ct-button-ex-ct-action
,command))
, at initargs))
@@ -104,7 +106,7 @@
(:default-initargs
:value (c-in nil)
:transition-fn (lambda (current-state state-table)
- ;(trc "CTFSM :transitionFN curr,table" currentstate statetable)
+ (trc "CTFSM :transitionFN curr,table" current-state state-table)
(or (cadr (member current-state state-table :test (if (stringp current-state)
#'string-equal
#'eql)))
@@ -112,9 +114,10 @@
:ct-action (lambda (self event)
(declare (ignorable event))
- (with-integrity (:change :ctfsm-action)
- (let ((newv (funcall (transition-fn self) (value self) (states self))))
- (ct-fsm-assume-value self newv))))))
+ (trc "twister ct-action" self event)
+ (with-integrity (:change :ctfsm-action)
+ (let ((newv (funcall (transition-fn self) (value self) (states self))))
+ (ct-fsm-assume-value self newv))))))
(defmethod ct-fsm-assume-value (self new-value)
(setf (value self) new-value))
@@ -146,24 +149,34 @@
'((4 . -2) (9 . -7) (4 . -12))))
:ll 0 :lt 0 :lr (u96ths 15) :lb (downs (u96ths 15))))
+(defmethod (setf .value) :around (new (self ct-twister))
+ (trcx ct-twister-value-set!!!!!!!!!!!! self new)
+ (call-next-method))
+
+(defobserver .value ((self ct-twister))
+ (when (eq :show-contents (md-name self))
+ (trcx contents-twister-value-changing!!!!!!! new-value old-value old-value-boundp)))
+
(export! a-twister)
(defmacro a-twister ((label component-args initial-open &rest twister-args) twisted-widget)
`(a-stack (, at component-args)
(a-row ()
- (make-kid 'ct-twister
- :md-name :show-contents
- :value (c-in ,initial-open)
- :visible (c? (^enabled))
- , at twister-args)
+ (or (car .cache)
+ (make-kid 'ct-twister
+ :md-name :show-contents
+ :value (c-in ,initial-open)
+ :visible (c? (^enabled))
+ , at twister-args))
,(if (stringp label)
`(make-kid 'ix-text
:text$ ,label
:style-id :button)
label)) ;; actually should be a form to build a widget
- (a-stack (:collapsed (c? (let ((tw (fm^ :show-contents)))
- (assert (eq .parent (fm-parent (fm-parent tw))))
- (not (value tw)))))
+ (a-stack (:collapsed (c? (eko ("collapsed!!!!!!!!!!!!" .cause)
+ (let ((tw (fm^ :show-contents)))
+ (assert (eq .parent (fm-parent (fm-parent tw))))
+ (not (value tw))))))
,twisted-widget)))
--- /project/cello/cvsroot/cello/focus-utilities.lisp 2006/06/26 17:05:20 1.4
+++ /project/cello/cvsroot/cello/focus-utilities.lisp 2006/11/13 05:29:26 1.5
@@ -40,7 +40,7 @@
(defmethod focus-on (self &optional focuser)
(c-assert (or self focuser))
- ;;(trc "focus-on self, focuser" self focuser)
+ (trc "focus-on self, focuser" self focuser)
(setf (focus (or focuser (s-focuser))) self))
(defmethod focus-gain (self)
--- /project/cello/cvsroot/cello/focus.lisp 2006/07/06 22:09:10 1.4
+++ /project/cello/cvsroot/cello/focus.lisp 2006/11/13 05:29:26 1.5
@@ -40,45 +40,45 @@
(defmodel focuser (ix-canvas)
(
(focus :initarg :focus
- :initform (c-in nil)
- :accessor focus)
+ :initform (c-in nil)
+ :accessor focus)
(textual-focus :initarg :textual-focus
- :initform nil #+chya (c? (bwhen (focus (and #+runtime-system (activep (swdw))
- (^focus)))
- (when (and (typep focus 'ct-text) ;; possibly any 'IXText?
- (^edit-active))
- focus)))
- :accessor textual-focus)
-
+ :initform nil #+chya (c? (bwhen (focus (and #+runtime-system (activep (swdw))
+ (^focus)))
+ (when (and (typep focus 'ct-text) ;; possibly any 'IXText?
+ (^edit-active))
+ focus)))
+ :accessor textual-focus)
+
(edit-active :initarg :edit-active
- :initform (c-in nil)
- :accessor edit-active)
-
- (insertion-pt :initform (c-in 0)
- :initarg :insertion-pt
- :accessor insertion-pt)
-
- (sel-end :initform (c-in nil)
- :accessor sel-end)
-
- (sel-range :documentation "selEnd identified during drag operation"
- :reader sel-range :initarg :sel-range
- :initform nil #+chya (c? (bwhen (focus (^textual-focus))
- (bwhen (click-evt (click-evt focus))
- (bwhen (mp (in-drag click-evt))
- (cttext-find-ip focus mp))))))
-
- (undo-data :cell nil :initarg :undo-data :accessor undo-data
- :initform nil #+hunh (new-undo-data)
- :documentation "Data structure holding undo information"
- )
+ :initform (c-in nil)
+ :accessor edit-active)
+
+ (insertion-pt :initform (c-in 0)
+ :initarg :insertion-pt
+ :accessor insertion-pt)
+
+ (sel-end :initform (c-in nil)
+ :accessor sel-end)
+
+ (sel-range :documentation "selEnd identified during drag operation"
+ :reader sel-range :initarg :sel-range
+ :initform nil #+chya (c? (bwhen (focus (^textual-focus))
+ (bwhen (click-evt (click-evt focus))
+ (bwhen (mp (in-drag click-evt))
+ (cttext-find-ip focus mp))))))
+
+ (undo-data :cell nil :initarg :undo-data :accessor undo-data
+ :initform nil #+hunh (new-undo-data)
+ :documentation "Data structure holding undo information"
)
- (:default-initargs
- :kids (c? (the-kids (^content)
- ; (mkPart :caret (CTEditcaret))
- ; (mkPart :selBox (IXEditSelection))
- ))))
+ )
+ (:default-initargs
+ :kids (c? (the-kids (^content)
+ ; (mkPart :caret (CTEditcaret))
+ ; (mkPart :selBox (IXEditSelection))
+ ))))
(defun focuser (self)
(swdw)
--- /project/cello/cvsroot/cello/ix-grid.lisp 2006/06/05 01:47:49 1.2
+++ /project/cello/cvsroot/cello/ix-grid.lisp 2006/11/13 05:29:26 1.3
@@ -208,3 +208,43 @@
(elt (kids grid) (+ (* row-no (col-ct grid)) col-no)))
+;;; --- ix dot grid ----------------------------------------------------------
+
+(export! ix-dot-grid dot-color ^dot-color dot-size ^dot-size)
+
+(defmd ix-dot-grid (ix-view)
+ dot-color
+ (dot-size 6)
+ (rows (c? (when (numberp (^value))
+ (floor (sqrt (abs (^value)))))))
+ (columns (c? (when (and (numberp (^value))
+ (numberp (^rows))
+ (plusp (^rows)))
+ (ceiling (abs (^value)) (^rows)))))
+ :ll (c? (if (^collapsed)
+ 0 (- (v2-h (^inset)))))
+ :lt (c? (if (^collapsed)
+ 0 (ups (v2-v (^inset)))))
+ :lb (c? (if (^collapsed)
+ 0 (+ (downs (* 2 (v2-v (^inset))))
+ (* (^rows) (- (+ 2 (^dot-size))))
+ -2)))
+ :lr (c? (if (^collapsed)
+ 0 (+ (* 2 (v2-h (^inset)))
+ (* (+ 2 (^dot-size)) (^columns))
+ -2)))
+ :pre-layer (c? (with-layers :off +gray+ :fill
+ (:poly-mode gl_front_and_back gl_fill)
+ (:rgba (^dot-color)))))
+
+(defmethod ix-paint ((self ix-dot-grid))
+ (let ((spacing 2)
+ (offset (ceiling (^dot-size) 2)))
+ (gl-point-size (^dot-size))
+ (gl-enable gl_point_smooth)
+ (with-gl-translation ((+ offset (v2-h (^inset))) (downs (+ offset (v2-v (^inset)))))
+ (with-gl-begun (gl_points)
+ (loop for pn below (abs (^value))
+ for row = (mod pn (^rows))
+ for col = (floor pn (^rows))
+ do (gl-vertex2f (* col (+ spacing (^dot-size)))(* row (- (+ spacing (^dot-size))))))))))
--- /project/cello/cvsroot/cello/ix-togl.lisp 2006/11/04 20:56:30 1.15
+++ /project/cello/cvsroot/cello/ix-togl.lisp 2006/11/13 05:29:26 1.16
@@ -280,7 +280,7 @@
(defmethod togl-reshape-using-class ((self ix-togl) &aux (width (ctk::togl-width (ctk::togl-ptr self)))
(height (ctk::togl-height (ctk::togl-ptr self))))
(let ((ctk::*tki* (ctk::togl-interp (ctk::togl-ptr self))))
- (trc nil "mg-window-reshape" self width height)
+ (trc "mg-window-reshape" self width height)
(gl-viewport 0 0 width height)
(gl-matrix-mode gl_projection)
More information about the Cello-cvs
mailing list