[cells-cvs] CVS cells/gui-geometry

[ktilton]

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))))