Update of /project/cells/cvsroot/cells/gui-geometry In directory clnet:/tmp/cvs-serv22722/gui-geometry Added Files: geo-macros.lisp Log Message: --- /project/cells/cvsroot/cells/gui-geometry/geo-macros.lisp 2007/12/11 19:35:16 NONE +++ /project/cells/cvsroot/cells/gui-geometry/geo-macros.lisp 2007/12/11 19:35:16 1.1 ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: gui-geometry; -*- #| Copyright (C) 2004 by Kenneth William Tilton This library is free software; you can redistribute it and/or modify it under the terms of the Lisp Lesser GNU Public License (http://opensource.franz.com/preamble.html), known as the LLGPL. This library is distributed WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the Lisp Lesser GNU Public License for more details. |# (in-package #:gui-geometry) (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)))))) (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)) (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))) (export! centered-h? centered-v?) (defmacro ^fill-down (upper-type &optional (padding 0)) (let ((filled (gensym))) `(let ((,filled (upper self ,upper-type))) #+shhh (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)))) ; "...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)))))) (defmacro ^fill-parent-right (&optional (inset 0)) `(lr-maintain-pr (- (inset-lr .parent) ,inset))) (defmacro ^fill-parent-down () `(lb-maintain-pb (inset-lb .parent))) (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))))