Update of /project/cells/cvsroot/cells/gui-geometry In directory clnet:/tmp/cvs-serv13961/gui-geometry

Added Files: coordinate-xform.lisp defpackage.lisp geo-data-structures.lisp geo-family.lisp geometer.lisp gui-geometry.lpr Log Message: Mostly adding a general-purpose GUI geometry component that makes good use of the Family class and specifically the kid-slotting mechanism.

--- /project/cells/cvsroot/cells/gui-geometry/coordinate-xform.lisp 2006/06/04 13:19:59 NONE +++ /project/cells/cvsroot/cells/gui-geometry/coordinate-xform.lisp 2006/06/04 13:19:59 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)

(defconstant *reference-dpi* 1440)

(let ( (logical-dpi 96) ;;1440) ; This is cello's internal dots per inch. This value is germane only if size references are unqualified by a function call. ; Size references should always be qualified, as in (:pts 6), except when specifying pen widths. ; (Pen widths may pose a special case -- we may need to match screen pens to print pens.)

(scan-resolution 300) ; This is the desired scan resolution, and the assumed resolution of all scans. ; Hypothetically, a scanner not capable of scanning at 300 dpi could make a big hash of this scheme. ; Rather than even pretend to support multiple resolutions within a study, for now we'll enforce 300 across the board. ; Dependencies on this spec can be identified by searching on scan-resolution.

(logical-screen-resolution 96) ; This is the internal logical screen resolution, which does _not_ have to equal the current LOGPIXELSX (LOGPIXELSY) value ; reported by GetDeviceCaps. The original thought was that we could use this to rescale _all_ drawing on the fly. Now that ; idea is being superseded by targetRes, but this functions (1) as a tacit targetRes for the outer window and (2) as a magic ; number to complicate debugging [we need to root out a few references in .bmp drawing, I think].

;;(printer-resolution 600) ; /// improve #'cs-printer-resolution to bypass this.

;;(emf-resolution 600)

)

(declare (ignorable logical-dpi scan-resolution logical-screen-resolution printer-resolution))

; Notice the somewhat nonstandard naming convention: ; #'uInches takes logical inches and returns logical units (DPI) ; so, for instance, if logical-dpi = 1440, then (uInches 0.5) = 720. (defun u-round (number &optional (divisor 1)) (multiple-value-bind (quotient remainder) (round number divisor) (declare (ignorable remainder)) ;(assert (zerop remainder)) ;(assert (zerop (mod quotient 15))) ;96ths quotient))

(defun udots (dots dpi) (u-round (* dots logical-dpi) dpi)) ;only the first value will be used.

(defun uinches (logical-inches) (u-round (* logical-inches logical-dpi))) ;only the first value will be used.

(defun uin (logical-inches) (uinches logical-inches))

(defun upoints (logical-points) (udots logical-points 72))

(defun upts (logical-points) (upoints logical-points))

(defun u96ths (logical-96ths) (udots logical-96ths 96))

(defun u8ths (logical-8ths) (udots logical-8ths 8))

(defun u16ths (logical-16ths) (udots logical-16ths 16))

(defun u32nds (logical-32nds) (udots logical-32nds 32))

(defun u120ths (logical-120ths) (udots logical-120ths 120))

(defun cs-logical-dpi () logical-dpi)

(defsetf cs-logical-dpi cs-logical-dpi-setf)

(defun cs-logical-dpi-setf (new-value) (setf logical-dpi new-value))

(defun cs-scan-resolution () scan-resolution)

(defun cs-logical-screen-resolution () logical-screen-resolution)

)

(defmethod u-cvt ((nn number) (units (eql :96ths)) ) (u96ths nn))

(defmethod u-cvt ((nn number) (units (eql :8ths)) ) (u8ths nn))

(defmethod u-cvt ((nn number) (units (eql :16ths)) ) (u16ths nn))

(defmethod u-cvt ((nn number) (units (eql :32nds)) ) (u32nds nn))

(defmethod u-cvt ((nn number) (units (eql :inches)) ) (uinches nn))

(defmethod u-cvt ((nn number) (units (eql :points)) ) (upoints nn))

(defmethod u-cvt (other units) (declare (ignore units)) other)

(defmethod u-cvt ((nns cons) units) (cons (u-cvt (car nns) units) (u-cvt (cdr nns) units)))

(defmacro u-cvt! (nn units) `(u-cvt ,nn ,units))

(defun uv2 (x y u-key) (apply #'mkv2 (u-cvt (list x y) u-key)))

;-----------------

(defun os-logical-screen-dpi () (break "need (win:GetDeviceCaps (device-context (screen *cg-system*)) win:LOGPIXELSX))"))

#+no(defun browser-target-resolution () (target-resolution (find-window :clinisys)))

; set to 96 because the code is trying to do rect-frames for the header before the window is init'ed.

(let ((current-target-resolution 96)) ;initialize when main window is created

(defun set-current-target-resolution (resolution) #+shh(trc "setting current-target-resolution to" resolution) (setf current-target-resolution resolution))

(defun cs-current-target-resolution () current-target-resolution)

(defun cs-target-res () current-target-resolution)

(defmacro with-target-resolution ((new-resolution) &rest body) (let ((old-resolution (gensym)) ) `(let ((,old-resolution (cs-current-target-resolution)) ) (prog2 (set-current-target-resolution ,new-resolution) (progn ,@body) (set-current-target-resolution ,old-resolution) )))) )

;converts screen pixels to logical pixels given the current target resolution OR OPTIONAL OTHER RES (defun scr2log (dots &optional (target-res (cs-target-res))) (round (* dots (cs-logical-dpi)) target-res))

(defun log2scr (logv &optional (target-res (cs-target-res))) (floor-round (* logv target-res ) (cs-logical-dpi)))

(defun cs-archos-dpi () (cs-logical-dpi))

(defun floor-round (x &optional (divisor 1)) (ceiling (- (/ x divisor) 1/2)))

;converts logical pixels to screen pixels given the current target resolution OR OPTIONAL OTHER RES (defun logical-to-screen-vector (dots &optional target-res) (let ((convert-res (or target-res (cs-target-res)))) (floor-round (* dots convert-res) (cs-logical-dpi))))

(defun logical-to-screen-point (point &optional target-res) (mkv2 (log2scr (v2-h point) target-res) (log2scr (v2-v point) target-res)))

(defun screen-to-logical-v2 (point &optional target-res) (mkv2 (scr2log (v2-h point) target-res) (scr2log (v2-v point) target-res)))

(defun nr-screen-to-logical (logical-rect screen-rect &optional target-res) (nr-make logical-rect (scr2log (r-left screen-rect) target-res) (scr2log (r-top screen-rect) target-res) (scr2log (r-right screen-rect) target-res) (scr2log (r-bottom screen-rect) target-res)))

; logical-to-target is a more sensible name throughout

(defun logical-to-target-vector (dots &optional target-res) (log2scr dots target-res)) ;--------------------------------------------------------------------------------------------

(defun r-logical-to-screen (logical-rect &optional target-res) (count-it :r-logical-to-screen) (nr-logical-to-screen (mkr 0 0 0 0) logical-rect target-res))

(defun nr-logical-to-screen (screen-rect logical-rect &optional target-res) (nr-make screen-rect (log2scr (r-left logical-rect) target-res) (log2scr (r-top logical-rect) target-res) (log2scr (r-right logical-rect) target-res) (log2scr (r-bottom logical-rect) target-res)))

;------------------------------------------------------------------------------------------------

;;;(defun set-scaling (window) ;;; #+shh(trc "targetResolution" (targetRes window)) ;;; ;;; (set-current-target-resolution (cs-logical-screen-resolution)) ;here and below, we'll probably make scalable ;;; ;(set-current-target-resolution (cs-logical-dpi)) ;;; (let ((dc (device-context window)) ;;; (display-dpi (cs-logical-screen-resolution)) ;... and use (targetRes window) ;;; (logical-dpi (cs-logical-dpi))) ;;; (os-SetMapMode dc win:MM_ISOTROPIC) ;;; (os-SetWindowExtEx dc logical-dpi logical-dpi ct:hnull) ;;; (os-SetViewportExtEx dc display-dpi display-dpi ct:hnull)))

(defun move-v2-x-y (v2 x y) (incf (v2-h v2) x) (incf (v2-v v2) y) v2)

(defmethod ncanvas-to-screen-point (self point) (ncanvas-to-screen-point (fm-parent self) (move-v2-x-y point (px self) (py self))))

(defmethod res-to-res ((amount number) from-res to-res) (if to-res (round (* amount from-res) to-res) from-res))

(defmethod res-to-res ((point v2) from-res to-res) (nres-to-res (copy-v2 point) from-res to-res))

#+no-2e-h (defmethod nres-to-res ((point v2) from-res to-res) (setf (v2-h point) (res-to-res (v2-h point) from-res to-res)) (setf (v2-v point) (res-to-res (v2-v point) from-res to-res)) point)

(defmethod res-to-res ((box rect) from-res to-res) (count-it :res-to-res) (nres-to-res (nr-copy (mkr 0 0 0 0) box) from-res to-res))

(defmethod nres-to-res :around (geo-thing from-res (to-res null)) (declare (ignore from-res)) geo-thing)

(defmethod nres-to-res ((box rect) from-res to-res) (setf (r-left box) (res-to-res (r-left box) from-res to-res)) (setf (r-top box) (res-to-res (r-top box) from-res to-res)) (setf (r-right box) (res-to-res (r-right box) from-res to-res)) (setf (r-bottom box) (res-to-res (r-bottom box) from-res to-res)) box)

(defun canvas-to-screen-box (self box) (count-it :canvas-to-screen-box) (nr-make-from-corners (mkr 0 0 0 0) (ncanvas-to-screen-point self (r-top-left box)) (ncanvas-to-screen-point self (r-bottom-right box))))

--- /project/cells/cvsroot/cells/gui-geometry/defpackage.lisp 2006/06/04 13:19:59 NONE +++ /project/cells/cvsroot/cells/gui-geometry/defpackage.lisp 2006/06/04 13:19:59 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.

|#

(defpackage #:gui-geometry (:nicknames #:geo) (:use #:common-lisp #:utils-kt #:cells) (:export #:geometer #:px #:py #:ll #:lt #:lr #:lb))--- /project/cells/cvsroot/cells/gui-geometry/geo-data-structures.lisp 2006/06/04 13:19:59 NONE +++ /project/cells/cvsroot/cells/gui-geometry/geo-data-structures.lisp 2006/06/04 13:19:59 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)

;-----------------------------

(defstruct v2 (h 0 ) (v 0 ) )

#+(or) (instance-slots (mkv2 1 2))

(defmethod print-object ((self v2) s) (format s "(~a ~a)" (v2-h self)(v2-v self)))

(defun mkv2 (h v) (make-v2 :h h :v v))

(defun v2= (a b) (and a b (= (v2-h a)(v2-h b)) (= (v2-v a)(v2-v b))))

(defun v2-add (p1 p2) (make-v2 :h (+ (v2-h p1) (v2-h p2)) :v (+ (v2-v p1) (v2-v p2))))

(defun v2-move (p1 x y) (make-v2 :h (+ (v2-h p1) x) :v (+ (v2-v p1) y)))

(defun v2-subtract (p1 p2) (make-v2 :h (- (v2-h p1) (v2-h p2)) :v (- (v2-v p1) (v2-v p2))))

(defun v2-in-rect (v2 r) (mkv2 (min (r-right r) (max (r-left r) (v2-h v2))) (min (r-top r) (max (r-bottom r) (v2-v v2)))))

(defun v2-in-rect-ratio (v2 r) (assert (<= (r-left r) (v2-h v2) (r-right r))) (assert (<= (r-bottom r) (v2-v v2) (r-top r))) (mkv2 (div-safe (- (v2-h v2) (r-left r)) (r-width r)) (div-safe (- (v2-v v2) (r-bottom r)) (r-height r))))

(defun div-safe (n d &optional (zero-div-return-value 1)) (if (zerop d) zero-div-return-value (/ n d)))

(defmethod c-value-incf (c (base v2) (delta number)) (declare (ignore c)) (mkv2 (+ (v2-h base) delta) (+ (v2-v base) delta)))

(defmethod c-value-incf (c (base v2) (delta v2)) (declare (ignore c)) (v2-add base delta))

; synapse support ; (defmethod delta-diff ((new v2) (old v2) (subtypename (eql 'v2))) (v2-subtract new old))

(defmethod delta-identity ((dispatcher number) (subtypename (eql 'v2))) (mkv2 0 0))

(defun long-v2 (long-hv) (c-assert (numberp long-hv)) (multiple-value-bind (fv fh) (floor long-hv 65536) (mkv2 fh fv)))

(defun long-x (long-hv) (c-assert (numberp long-hv)) (mod long-hv 65536))

(defun long-y (long-hv) (c-assert (numberp long-hv)) (floor long-hv 65536))

[229 lines skipped] --- /project/cells/cvsroot/cells/gui-geometry/geo-family.lisp 2006/06/04 13:19:59 NONE +++ /project/cells/cvsroot/cells/gui-geometry/geo-family.lisp 2006/06/04 13:19:59 1.1

[369 lines skipped] --- /project/cells/cvsroot/cells/gui-geometry/geometer.lisp 2006/06/04 13:19:59 NONE +++ /project/cells/cvsroot/cells/gui-geometry/geometer.lisp 2006/06/04 13:19:59 1.1

[722 lines skipped] --- /project/cells/cvsroot/cells/gui-geometry/gui-geometry.lpr 2006/06/04 13:19:59 NONE +++ /project/cells/cvsroot/cells/gui-geometry/gui-geometry.lpr 2006/06/04 13:19:59 1.1

[809 lines skipped]