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]