[cells-cvs] CVS cells/gui-geometry
ktilton
ktilton at common-lisp.net
Fri Nov 30 16:51:20 UTC 2007
Update of /project/cells/cvsroot/cells/gui-geometry
In directory clnet:/tmp/cvs-serv2729/gui-geometry
Modified Files:
geo-data-structures.lisp geo-family.lisp geometer.lisp
gui-geometry.lpr
Log Message:
--- /project/cells/cvsroot/cells/gui-geometry/geo-data-structures.lisp 2006/12/12 15:58:42 1.9
+++ /project/cells/cvsroot/cells/gui-geometry/geo-data-structures.lisp 2007/11/30 16:51:19 1.10
@@ -17,7 +17,7 @@
(in-package :gui-geometry)
(eval-now!
- (export '(v2 mkv2)))
+ (export '(v2 mkv2 v2=)))
;-----------------------------
(defstruct v2
--- /project/cells/cvsroot/cells/gui-geometry/geo-family.lisp 2006/11/13 05:28:08 1.11
+++ /project/cells/cvsroot/cells/gui-geometry/geo-family.lisp 2007/11/30 16:51:19 1.12
@@ -102,6 +102,47 @@
(^prior-sib-pr self (spacing .parent)))))))))))
+(defun ^prior-sib-pb (self &optional (spacing 0)) ;; just keeping with -pt variant till both converted to defun
+ (bif (psib (find-prior self (kids .parent)
+ :test (lambda (sib)
+ (not (collapsed sib)))))
+ (eko (nil "^prior-sib-pb spc pb-psib -lt" (- (abs spacing)) (pb psib) (- (^lt)))
+ (+ (- (abs spacing)) ;; force spacing to minus(= down for OpenGL)
+ (pb psib)))
+ 0))
+
+(defun centered-h? ()
+ (c? (px-maintain-pl (round (- (inset-width .parent) (l-width self)) 2))))
+
+(defun centered-v? ()
+ (c? (py-maintain-pt (round (- (l-height .parent) (l-height self)) -2))))
+
+;--------------- geo.row.flow ----------------------------
+(export! geo-row-flow)
+
+(defmodel geo-row-flow (geo-inline)
+ ((spacing-hz :cell nil :initarg :spacing-hz :initform 0 :reader spacing-hz)
+ (spacing-vt :cell nil :initarg :spacing-vt :initform 0 :reader spacing-vt)
+ (aligned :cell nil :initarg :aligned :initform nil :reader aligned))
+ (:default-initargs
+ :lb (c? (geo-kid-wrap self 'pb))
+ :kid-slots (lambda (self)
+ (declare (ignore self))
+
+ (list
+ (mk-kid-slot (py)
+ (c? (py-maintain-pt
+ (let ((ph (^prior-sib-pr self (spacing-hz .parent) (aligned .parent))))
+ (if (> (+ ph (l-width self)(outset .parent)) (l-width .parent))
+ (^prior-sib-pb self (spacing-vt .parent))
+ (^prior-sib-pt self))))))
+ (mk-kid-slot (px)
+ (c? (px-maintain-pl
+ (let ((ph (^prior-sib-pr self (spacing-hz .parent) (aligned .parent))))
+ (if (> (+ ph (l-width self)(outset .parent)) (l-width .parent))
+ 0
+ ph)))))))))
+
#| archive
(defmodel geo-row-fv (family-values geo-row)())
@@ -136,28 +177,8 @@
(pt psib))
0))))))))
-;--------------- IGRowFlow ----------------------------
+|#
+
+
-(defmodel geo-row-flow (geo-row)
- ((spacing-hz :cell nil :initarg :spacing-hz :initform 0 :reader spacing-hz)
- (spacing-vt :cell nil :initarg :spacing-vt :initform 0 :reader spacing-vt)
- (aligned :cell nil :initarg :aligned :initform nil :reader aligned))
- (:default-initargs
- :lb (c? (geo-kid-wrap self 'pb))
- :kid-slots (lambda (self)
- (declare (ignore self))
- (list
- (mk-kid-slot (py)
- (c? (py-maintain-pt
- (let ((ph (^prior-sib-pr self (spacing-hz .parent) (aligned .parent))))
- (if (> (+ ph (l-width self)) (l-width .parent))
- (^prior-sib-pb self (spacing-vt .parent))
- (^prior-sib-pt self))))))
- (mk-kid-slot (px)
- (c? (px-maintain-pl
- (let ((ph (^prior-sib-pr self (spacing-hz .parent) (aligned .parent))))
- (if (> (+ ph (l-width self)) (l-width .parent))
- 0
- ph)))))))))
-|#
--- /project/cells/cvsroot/cells/gui-geometry/geometer.lisp 2006/11/13 05:28:08 1.12
+++ /project/cells/cvsroot/cells/gui-geometry/geometer.lisp 2007/11/30 16:51:19 1.13
@@ -87,18 +87,7 @@
;(trc "inner outer" inner outer)
))
-(defmacro ^offset-within (inner outer)
- (let ((offset-h (gensym)) (offset-v (gensym)) (from (gensym)))
- `(let ((,offset-h 0)
- (,offset-v 0))
- (do ((,from ,inner (fm-parent ,from)))
- ((or (null ,from)
- (eql ,from ,outer))
- ;
- (mkv2 ,offset-h ,offset-v))
-
- (incf ,offset-h (px ,from))
- (incf ,offset-v (py ,from))))))
+
;----------- OfKids -----------------------
;
@@ -127,6 +116,8 @@
(v2-subtract outer-v2
(mkv2 (px inner) (py inner))))))
+(export! h-xlate v-xlate)
+
(defun h-xlate (outer inner outer-h)
(if (eql outer inner)
outer-h
@@ -212,18 +203,6 @@
;---------------------------------
-(defmacro ^ll-width (width)
- `(- (lr self) ,width))
-
-(defmacro ^lr-width (width)
- `(+ (ll self) ,width))
-
-(defmacro ^lt-height (height)
- `(- (lb self) ,height))
-
-(defmacro ^lb-height (height)
- `(+ (lt self) ,height))
-
;----------------------------------
(export! geo-kid-wrap)
@@ -235,108 +214,6 @@
((pr pt) 'fm-max-kid)) self bound)
(outset self)))
-(defmacro ll-maintain-pL (pl)
- `(- ,pL (^px)))
-
-(defmacro lr-maintain-pr (pr)
- `(- ,pr (^px)))
-
-(defmacro ^fill-right (upperType &optional (padding 0))
- `(call-^fillRight self (upper self ,upperType) ,padding))
-
-;recalc local top based on pT and offset
-(defmacro lt-maintain-pT (pT)
- `(- ,pT (^py)))
-
-;recalc local bottom based on pB and offset
-(defmacro lb-maintain-pB (pB)
- `(- ,pB (^py)))
-
-;--------------
-;recalc offset based on p and local
-(defmacro px-maintain-pL (pL)
- (let ((lL (gensym)))
- `(- ,pL (let ((,lL (^lL)))
- (c-assert ,lL () "^px-maintain-pL sees nil lL for ~a" self)
- ,lL))))
-
-(defmacro px-maintain-pR (pR)
- `(- ,pR (^lR)))
-
-(defmacro py-maintain-pT (pT)
- `(- ,pT (^lT)))
-
-(defmacro py-maintain-pB (pB)
- `(- ,pB (^lB)))
-
-(defmacro centered-h? ()
- `(c? (px-maintain-pl (round (- (l-width .parent) (l-width self)) 2))))
-
-(defmacro ^centered-v? ()
- `(c? (py-maintain-pt (round (- (l-height .parent) (l-height self)) 2))))
-
-(defmacro ^fill-down (upper-type &optional (padding 0))
- (let ((filled (gensym)))
- `(let ((,filled (upper self ,upper-type)))
- #+qt (trc "^fillDown sees filledLR less offH"
- (lb ,filled)
- ,padding
- (v2-v (offset-within self ,filled)))
- (- (lb ,filled)
- ,padding
- (v2-v (offset-within self ,filled))))))
-
-(defmacro ^lbmax? (&optional (padding 0))
- `(c? (lb-maintain-pb (- (inset-lb .parent)
- ,padding))))
-
-(defmacro ^lrmax? (&optional (padding 0))
- `(c? (lr-maintain-pr (- (inset-lr .parent)
- ,padding))))
-
-(defun ^prior-sib-pb (self &optional (spacing 0))
- (bif (psib (find-prior self (kids .parent)
- :test (lambda (sib)
- (not (collapsed sib)))))
- (eko (nil "^prior-sib-pb spc pb-psib -lt" (- (abs spacing)) (pb psib) (- (^lt)))
- (+ (- (abs spacing)) ;; force spacing to minus(= down for OpenGL)
- (pb psib)))
- 0))
-
-(defmacro ^prior-sib-pt (self &optional (spacing 0))
- (let ((kid (gensym))
- (psib (gensym)))
- `(let* ((,kid ,self)
- (,psib (find-prior ,kid (kids (fm-parent ,kid)))))
- ;(trc "^priorSib-pb > kid, sib" ,kid ,pSib)
- (if ,psib
- (+ (- (abs ,spacing)) (pt ,psib))
- 0))))
-
-; "...return the sib's pL [if ,alignment is :left] or pR, plus optional spacing"
-
-(defmacro ^prior-sib-pr (self &optional (spacing 0) alignment)
- (let ((kid (gensym))
- (psib (gensym)))
- `(let* ((,kid ,self)
- (,psib (find-prior ,kid (kids (fm-parent ,kid)) :test (lambda (k) (not (collapsed k))))))
- (if ,psib
- (case ,alignment
- (:left (+ ,spacing (pl ,psib)))
- (otherwise (+ ,spacing (pr ,psib))))
- 0))))
-
-(defmacro ^px-stay-right-of (other &key (by '0))
- `(px-maintain-pl (+ (pr (fm-other ,other)) ,by)))
-
-; in use; adjust offset to maintain pL based on ,justify
-(defmacro ^px-self-centered (justify)
- `(px-maintain-pl
- (ecase ,justify
- (:left 0)
- (:center (floor (- (inset-width .parent) (l-width self)) 2))
- (:right (- (inset-lr .parent) (l-width self))))))
-
; in use; same idea for pT
(defun py-self-centered (self justify)
(py-maintain-pt
@@ -345,9 +222,3 @@
(:center (floor (- (inset-height .parent) (l-height self)) -2))
(:bottom (downs (- (inset-height .parent) (l-height self)))))))
-(defmacro ^fill-parent-right (&optional (inset 0))
- `(lr-maintain-pr (- (inset-lr .parent) ,inset)))
-
-(defmacro ^fill-parent-down ()
- `(lb-maintain-pb (inset-lb .parent)))
-
--- /project/cells/cvsroot/cells/gui-geometry/gui-geometry.lpr 2007/01/29 06:44:03 1.8
+++ /project/cells/cvsroot/cells/gui-geometry/gui-geometry.lpr 2007/11/30 16:51:19 1.9
@@ -1,4 +1,4 @@
-;; -*- lisp-version: "8.0 [Windows] (Jan 22, 2007 8:01)"; cg: "1.81"; -*-
+;; -*- lisp-version: "8.0 [Windows] (Jan 29, 2007 18:02)"; cg: "1.81"; -*-
(in-package :cg-user)
@@ -6,6 +6,7 @@
(define-project :name :gui-geometry
:modules (list (make-instance 'module :name "defpackage.lisp")
+ (make-instance 'module :name "geo-macros.lisp")
(make-instance 'module :name
"geo-data-structures.lisp")
(make-instance 'module :name "coordinate-xform.lisp")
More information about the Cells-cvs
mailing list