[pal-cvs] CVS pal-gui
tneste
tneste at common-lisp.net
Mon Oct 22 12:03:37 UTC 2007
Update of /project/pal/cvsroot/pal-gui
In directory clnet:/tmp/cvs-serv31975
Modified Files:
gob.lisp gui.lisp widgets.lisp
Added Files:
license.txt
Log Message:
Fixed packing. I think.
--- /project/pal/cvsroot/pal-gui/gob.lisp 2007/10/17 17:02:52 1.6
+++ /project/pal/cvsroot/pal-gui/gob.lisp 2007/10/22 12:03:35 1.7
@@ -1,7 +1,6 @@
(in-package :pal-gui)
(defvar *root* nil)
-(defvar *gobs* nil)
(defvar *drag-start-pos* nil)
(defvar *relative-drag-start-pos* nil)
(defvar *focused-gob* nil)
@@ -18,12 +17,16 @@
(activep :accessor activep :initform t :initarg :activep)
(width :accessor width-of :initarg :width :initform 0)
(height :accessor height-of :initarg :height :initform 0)
+ (min-width :accessor min-width-of :initarg :min-width)
+ (min-height :accessor min-height-of :initarg :min-height)
(childs :reader childs-of :initform nil)))
-
-(defmethod initialize-instance :after ((g gob) &key (parent *root*) &allow-other-keys)
- (setf (parent-of g) parent)
- (push g *gobs*))
+(defmethod initialize-instance :after ((g gob) &key (min-height) (min-width) (parent *root*) &allow-other-keys)
+ (unless min-width
+ (setf (min-width-of g) (width-of g)))
+ (unless min-height
+ (setf (min-height-of g) (height-of g)))
+ (setf (parent-of g) parent))
(defgeneric repaint (gob))
(defmethod repaint :around ((g gob))
@@ -76,10 +79,6 @@
(defmethod on-select ((gob gob) pos)
nil)
-(defgeneric on-destroy (gob))
-(defmethod on-destroy ((gob gob))
- nil)
-
(defgeneric on-drag (gob start-pos delta-pos))
(defmethod on-drag ((gob gob) start-pos delta)
(declare (ignore start-pos delta))
@@ -114,28 +113,26 @@
(defgeneric abandon (parent child))
(defmethod abandon ((parent gob) (child gob))
(setf (slot-value parent 'childs) (remove child (slot-value parent 'childs))
- (parent-of child) nil))
+ (slot-value child 'parent) nil))
(defgeneric (setf parent-of) (parent child))
-(defmethod (setf parent-of) ((parent gob) (child gob))
+(defmethod (setf parent-of) (parent (child gob))
(when (parent-of child)
(abandon (parent-of child) child))
- (adopt parent child))
-
-(defgeneric min-height-of (gob))
-(defmethod min-height-of ((g gob))
- (if (childs-of g)
- (+ (* (length (childs-of g)) (gap-of g))
- (loop for c in (childs-of g) summing (if (y-expand-p c) 0 (min-height-of c))))
- (height-of g)))
-
-(defgeneric min-width-of (gob))
-(defmethod min-width-of ((g gob))
- (if (childs-of g)
- (+ (* (length (childs-of g)) (gap-of g))
- (loop for c in (childs-of g) summing (if (x-expand-p c) 0 (min-width-of c))))
- (width-of g)))
+ (when parent
+ (adopt parent child)))
+(defmethod (setf width-of) (width (g gob))
+ (when (/= (slot-value g 'width) width)
+ (setf (slot-value g 'width) width)
+ (pack g))
+ (setf (slot-value g 'width) width))
+
+(defmethod (setf height-of) (height (g gob))
+ (when (/= (slot-value g 'height) height)
+ (setf (slot-value g 'height) height)
+ (pack g))
+ (setf (slot-value g 'height) height))
@@ -155,21 +152,29 @@
(call-next-method)
(pack parent))
+(defmethod min-width-of ((g v-packing))
+ (+ (loop for c in (childs-of g) maximizing (min-width-of c)) (* 2 (xpad-of g))))
+
+(defmethod min-height-of ((g v-packing))
+ (+ (* (1- (length (childs-of g))) (gap-of g)) (* 2 (ypad-of g))
+ (loop for c in (childs-of g) summing (min-height-of c))))
+
(defmethod pack ((g v-packing))
- (with-accessors ((gap gap-of) (width width-of) (height height-of) (pos pos-of) (childs childs-of) (ypad ypad-of) (xpad xpad-of)) g
+ (with-accessors ((gap gap-of) (width width-of) (min-height min-height-of) (height height-of) (pos pos-of)
+ (parent parent-of) (childs childs-of) (ypad ypad-of) (xpad xpad-of)) g
(let* ((exp-count (count-if #'y-expand-p childs))
- (solids-need (min-height-of g))
- (exp-size (- height solids-need (* 2 ypad))))
+ (exp-size (- height (+ (* (1- (length (childs-of g))) (gap-of g)) (* 2 (ypad-of g))
+ (loop for c in (childs-of g) summing (if (y-expand-p c) 0 (min-height-of c)))))))
(dolist (c childs)
(when (y-expand-p c)
- (setf (height-of c) (max 10 (truncate exp-size exp-count))))
+ (setf (height-of c) (max (min-height-of c) (truncate exp-size exp-count))))
(when (x-expand-p c)
- (setf (width-of c) (- width (* 2 xpad))))
- (pack c)))
+ (setf (width-of c) (- width (* 2 xpad))))))
(let ((cpos (v xpad ypad)))
(dolist (c (reverse childs))
(setf (pos-of c) cpos)
- (setf cpos (v+ cpos (v 0 (+ gap (height-of c)))))))))
+ (setf cpos (v+ cpos (v 0 (+ gap (height-of c)))))))
+ (pack parent)))
@@ -179,21 +184,29 @@
(ypad :accessor ypad-of :initarg :ypad :initform 0)
(gap :accessor gap-of :initarg :gap :initform 0)))
+(defmethod min-height-of ((g h-packing))
+ (+ (loop for c in (childs-of g) maximizing (min-height-of c)) (gap-of g) (* 2 (ypad-of g))))
+
+(defmethod min-width-of ((g h-packing))
+ (+ (* (1- (length (childs-of g))) (gap-of g) (* 2 (xpad-of g)))
+ (loop for c in (childs-of g) summing (min-width-of c))))
+
(defmethod pack ((g h-packing))
- (with-accessors ((gap gap-of) (height height-of) (width width-of) (pos pos-of) (childs childs-of) (ypad ypad-of) (xpad xpad-of)) g
+ (with-accessors ((gap gap-of) (height height-of) (min-width min-width-of) (width width-of) (pos pos-of)
+ (parent parent-of) (childs childs-of) (ypad ypad-of) (xpad xpad-of)) g
(let* ((exp-count (count-if #'x-expand-p childs))
- (solids-need (min-width-of g))
- (exp-size (- width solids-need (* 2 xpad))))
+ (exp-size (- width (+ (* (1- (length (childs-of g))) (gap-of g)) (* 2 (xpad-of g))
+ (loop for c in (childs-of g) summing (if (x-expand-p c) 0 (min-height-of c)))))))
(dolist (c childs)
(when (x-expand-p c)
- (setf (width-of c) (max 10 (truncate exp-size exp-count))))
+ (setf (width-of c) (max (min-width-of c) (truncate exp-size exp-count))))
(when (y-expand-p c)
- (setf (height-of c) (- height (* 2 ypad))))
- (pack c)))
+ (setf (height-of c) (- height (* 2 ypad))))))
(let ((cpos (v xpad ypad)))
(dolist (c (reverse childs))
(setf (pos-of c) cpos)
- (setf cpos (v+ cpos (v (+ gap (width-of c)) 0)))))))
+ (setf cpos (v+ cpos (v (+ gap (width-of c)) 0)))))
+ (pack parent)))
--- /project/pal/cvsroot/pal-gui/gui.lisp 2007/10/16 21:46:09 1.3
+++ /project/pal/cvsroot/pal-gui/gui.lisp 2007/10/22 12:03:35 1.4
@@ -6,7 +6,6 @@
`(block event-loop
(cffi:with-foreign-object (,event :char 500)
(let ((key-up (lambda (key)
-
(case key
(:key-mouse-1 (cond
(*pointed-gob*
@@ -32,12 +31,12 @@
(loop
(pal::do-event ,event key-up key-down ,mouse-motion-fn ,quit-fn)
, at redraw
- (let ((g (gob-at-point (get-mouse-pos))))
+ (let ((g (first (last (active-gobs-at-point (get-mouse-pos) *root*)))))
+ (setf *pointed-gob* g)
(cond
(*armed-gob*
(on-drag *armed-gob* *relative-drag-start-pos* (v- *drag-start-pos* (get-mouse-pos))))
- (t (setf *pointed-gob* g)
- (when (and g (not (activep g)))
+ (t (when (and g (not (activep g)))
(when *pointed-gob*
(on-leave *pointed-gob*))
(on-enter g)))))
@@ -55,12 +54,19 @@
(close-pal))))
+(defun active-gobs-at-point (point parent)
+ (let ((c (find-if (lambda (c)
+ (point-inside-p c point))
+ (childs-of parent))))
+ (if c
+ (if (activep c)
+ (cons c (active-gobs-at-point point c))
+ (active-gobs-at-point point c))
+ nil)))
+
(defun init-gui ()
- (setf *gobs* nil
- *root* (make-instance 'root)))
+ (setf *root* (make-instance 'root :parent nil)
+ *gui-font* (tag 'pal::default-font)))
(defun update-gui ()
- (repaint *root*))
-
-(defun gob-at-point (point)
- (find-if (lambda (g) (and (activep g) (point-inside-p g point))) *gobs*))
+ (repaint *root*))
\ No newline at end of file
--- /project/pal/cvsroot/pal-gui/widgets.lisp 2007/10/17 17:02:52 1.6
+++ /project/pal/cvsroot/pal-gui/widgets.lisp 2007/10/22 12:03:35 1.7
@@ -1,22 +1,23 @@
(in-package :pal-gui)
-(defparameter *window-color* '(160 160 160 128))
-(defparameter *widget-color* '(180 180 180 255))
+(defparameter *window-color* '(200 200 200 255))
+(defparameter *widget-color* '(210 210 210 255))
(defparameter *text-color* '(0 0 0 255))
(defparameter *paper-color* '(255 255 200 255))
+(defvar *gui-font* nil)
-(defun get-m (&optional font)
- (truncate (* (get-font-height font) 1.5)))
+(defun get-m ()
+ (truncate (* (get-font-height *gui-font*) 1.5)))
-(defun get-text-bounds (string &optional font)
- (let ((fh (get-font-height font)))
- (values (max (truncate (* 1.5 fh)) (+ (get-text-size string) fh))
+(defun get-text-bounds (string)
+ (let ((fh (get-font-height *gui-font*)))
+ (values (max (truncate (* 1.5 fh)) (+ (get-text-size string *gui-font*) fh))
(truncate (* fh 1.5)))))
-(defun get-text-offset (&optional font)
- (let ((fh (get-font-height font)))
+(defun get-text-offset ()
+ (let ((fh (get-font-height *gui-font*)))
(v (truncate fh 2) (truncate fh 4))))
(defun draw-frame (pos width height color &key style (border 1) (fill t))
@@ -46,19 +47,6 @@
-(defgeneric present (object gob width height))
-
-(defmethod present :around (object (g gob) width height)
- (let ((ap (absolute-pos-of g)))
- (with-clipping ((1+ (vx ap)) (1+ (vy ap)) (- (width-of g) 2) (- (height-of g) 2))
- (call-next-method))))
-
-(defmethod present (object (g gob) width height)
- (with-blend (:color *text-color*)
- (draw-text (format nil "~a" object) (get-text-offset))))
-
-
-
(defclass widget (gob)
@@ -67,9 +55,7 @@
(on-button-down :accessor on-button-down-of :initarg :on-button-down-select :initform (lambda (widget pos) (declare (ignore widget pos)) nil))
(on-button-up :accessor on-button-up-of :initarg :on-button-up-select :initform (lambda (widget pos) (declare (ignore widget pos)) nil))
(on-enter :accessor on-enter-of :initarg :on-enter :initform (lambda (widget) (declare (ignore widget)) nil))
- (on-leave :accessor on-leave-of :initarg :on-leave :initform (lambda (widget) (declare (ignore widget)) nil))
- (on-destroy :accessor on-destroy-of :initarg :on-destroy :initform (lambda (widget) (declare (ignore widget)) nil)))
-
+ (on-leave :accessor on-leave-of :initarg :on-leave :initform (lambda (widget) (declare (ignore widget)) nil)))
(:default-initargs :width (get-m) :height (get-m)))
(defmethod on-drag :around ((g widget) pos d)
@@ -96,9 +82,7 @@
(unless (funcall (on-leave-of g) g)
(call-next-method)))
-(defmethod on-destroy :around ((g widget))
- (unless (funcall (on-destroy-of g))
- (call-next-method)))
+
@@ -167,13 +151,13 @@
(draw-rectangle (v 0 0) width (get-m) 0 0 0 64)
(draw-line (v 0 (get-m)) (v width (get-m)) 0 0 0 160)
(draw-line (v 0 (1+ (get-m))) (v width (1+ (get-m))) 0 0 0 64)
+ (draw-line (v 0 (+ (get-m) 2)) (v width (+ (get-m) 2)) 0 0 0 32)
(with-blend (:color '(255 255 255 255))
(draw-text label (get-text-offset)))))
-
(defclass button (widget)
((value :accessor value-of :initform "" :initarg :value))
(:default-initargs :x-expand-p t))
@@ -183,8 +167,9 @@
(cond
((armedp g)
(draw-frame (v 0 0) width height *widget-color* :style :sunken :border 2)
- (with-blend (:color *text-color*)
- (present value g width height)))
+ (with-transformation (:pos (v 1 1))
+ (with-blend (:color *text-color*)
+ (present value g width height))))
((pointedp g)
(draw-frame (v 0 0) width height *widget-color* :border 2 :style :raised)
(with-blend (:color *text-color*)
@@ -317,14 +302,40 @@
(defclass list-box (h-box)
()
- (:default-initargs :gap 3 :xpad 0 :ypad 0 :y-expand-p t :x-expand-p t))
+ (:default-initargs :gap 3 :y-expand-p t :x-expand-p t))
(defmethod initialize-instance :after ((g list-box) &key items (item-height (get-m)) &allow-other-keys)
- (let* ((lv (make-instance 'list-view :items items :item-height item-height :parent g)))
- (make-instance 'v-slider :parent g
- :max-value (* item-height (length items))
- :page-size (lambda () (height-of lv))
- :on-drag (lambda (g pos d)
- (declare (ignore pos d))
- (setf (scroll-of lv) (value-of g))
- nil))))
\ No newline at end of file
+ (let* ((list-view (make-instance 'list-view :items items :item-height item-height :parent g))
+ (slider-box (make-instance 'v-box :parent g :gap 0 :x-expand-p nil))
+ (up-button (make-instance 'button :parent slider-box :x-expand-p nil :y-expand-p nil))
+ (slider (make-instance 'v-slider
+ :parent slider-box
+ :max-value (* item-height (length items))
+ :page-size (lambda () (height-of list-view))
+ :on-drag (lambda (g pos d)
+ (declare (ignore pos d))
+ (setf (scroll-of list-view) (value-of g))
+ nil)))
+ (down-button (make-instance 'button :parent slider-box :x-expand-p nil :y-expand-p nil))
+ )))
+
+
+
+
+
+
+
+
+
+
+
+(defgeneric present (object gob width height))
+
+(defmethod present :around (object (g widget) width height)
+ (let ((ap (absolute-pos-of g)))
+ (with-clipping ((1+ (vx ap)) (1+ (vy ap)) (- (width-of g) 2) (- (height-of g) 2))
+ (call-next-method))))
+
+(defmethod present (object (g widget) width height)
+ (with-blend (:color *text-color*)
+ (draw-text (format nil "~a" object) (get-text-offset))))
\ No newline at end of file
--- /project/pal/cvsroot/pal-gui/license.txt 2007/10/22 12:03:37 NONE
+++ /project/pal/cvsroot/pal-gui/license.txt 2007/10/22 12:03:37 1.1
PAL-GUI is published under the MIT license
Copyright (c) 2007 Tomi Neste
Permission is hereby granted, free of charge, to any person obtaining a copy of
this software and associated documentation files (the "Software"), to deal in
the Software without restriction, including without limitation the rights to
use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies
of the Software, and to permit persons to whom the Software is furnished to do
so, subject to the following conditions:
The above copyright notice and this permission notice shall be included in all
copies or substantial portions of the Software.
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
SOFTWARE.
More information about the Pal-cvs
mailing list