[graphic-forms-cvs] r153 - in trunk: docs/manual src/demos/unblocked src/tests/uitoolkit src/uitoolkit/graphics src/uitoolkit/widgets
junrue at common-lisp.net
junrue at common-lisp.net
Mon Jun 5 18:42:47 UTC 2006
Author: junrue
Date: Mon Jun 5 14:42:47 2006
New Revision: 153
Modified:
trunk/docs/manual/api.texinfo
trunk/src/demos/unblocked/tiles-panel.lisp
trunk/src/tests/uitoolkit/drawing-tester.lisp
trunk/src/tests/uitoolkit/event-tester.lisp
trunk/src/tests/uitoolkit/mock-objects.lisp
trunk/src/uitoolkit/graphics/magick-core-api.lisp
trunk/src/uitoolkit/widgets/widget-utils.lisp
trunk/src/uitoolkit/widgets/widget.lisp
Log:
fixed silly redundant floor forms
Modified: trunk/docs/manual/api.texinfo
==============================================================================
--- trunk/docs/manual/api.texinfo (original)
+++ trunk/docs/manual/api.texinfo Mon Jun 5 14:42:47 2006
@@ -225,7 +225,7 @@
@end deftp
@anchor{control}
- at deftp Class control
+ at deftp Class control brush-color brush-handle font pixel-point maximum-size minimum-size text-color
The base class for widgets having pre-defined native behavior. It derives from
@ref{widget}.
@end deftp
Modified: trunk/src/demos/unblocked/tiles-panel.lisp
==============================================================================
--- trunk/src/demos/unblocked/tiles-panel.lisp (original)
+++ trunk/src/demos/unblocked/tiles-panel.lisp Mon Jun 5 14:42:47 2006
@@ -46,8 +46,8 @@
(gfs:make-point :x xpos :y ypos))))
(defun window->tiles (pnt)
- (let ((xpos (floor (/ (1- (gfs:point-x pnt)) +tile-bmp-width+)))
- (ypos (- +vert-tile-count+ (1+ (floor (/ (1- (gfs:point-y pnt)) +tile-bmp-height+))))))
+ (let ((xpos (floor (1- (gfs:point-x pnt)) +tile-bmp-width+))
+ (ypos (- +vert-tile-count+ (1+ (floor (1- (gfs:point-y pnt)) +tile-bmp-height+)))))
(if (or (>= xpos +horz-tile-count+) (>= ypos +vert-tile-count+))
nil
(gfs:make-point :x xpos :y ypos))))
Modified: trunk/src/tests/uitoolkit/drawing-tester.lisp
==============================================================================
--- trunk/src/tests/uitoolkit/drawing-tester.lisp (original)
+++ trunk/src/tests/uitoolkit/drawing-tester.lisp Mon Jun 5 14:42:47 2006
@@ -301,7 +301,7 @@
(setf pnt (draw-a-string gc pnt nil "Courier New" 14 '(:italic :bold :underline) nil))
(setf pnt (draw-a-string gc pnt nil "Courier New" 18 '(:strikeout) nil))
- (setf (gfs:point-x pnt) (+ (floor (/ (gfs:size-width (gfw:client-size *drawing-win*)) 2)) 10))
+ (setf (gfs:point-x pnt) (+ (floor (gfs:size-width (gfw:client-size *drawing-win*)) 2) 10))
(setf (gfs:point-y pnt) 0)
(setf pnt (draw-a-string gc pnt (format nil "tab~ctab~ctab" #\Tab #\Tab) "Verdana" 10 nil '(:tab)))
(setf pnt (draw-a-string gc pnt (format nil "even~cmore~ctabs" #\Tab #\Tab) "Verdana" 10 nil '(:tab)))
Modified: trunk/src/tests/uitoolkit/event-tester.lisp
==============================================================================
--- trunk/src/tests/uitoolkit/event-tester.lisp (original)
+++ trunk/src/tests/uitoolkit/event-tester.lisp Mon Jun 5 14:42:47 2006
@@ -52,7 +52,7 @@
(setf (gfg:background-color gc) gfg:*color-white*)
(setf (gfg:foreground-color gc) gfg:*color-blue*)
(let* ((sz (gfw:client-size window))
- (pnt (gfs:make-point :x 0 :y (floor (/ (gfs:size-height sz) 2)))))
+ (pnt (gfs:make-point :x 0 :y (floor (gfs:size-height sz) 2))))
(gfg:draw-text gc *event-tester-text* pnt)))
(defmethod gfw:event-close ((d event-tester-window-events) widget time)
Modified: trunk/src/tests/uitoolkit/mock-objects.lisp
==============================================================================
--- trunk/src/tests/uitoolkit/mock-objects.lisp (original)
+++ trunk/src/tests/uitoolkit/mock-objects.lisp Mon Jun 5 14:42:47 2006
@@ -79,7 +79,7 @@
size))
(defmethod gfw:text-baseline ((widget mock-widget))
- (floor (/ (* (gfs:size-height (min-size-of widget)) 3) 4)))
+ (floor (* (gfs:size-height (min-size-of widget)) 3) 4))
(defmethod gfw:visible-p ((widget mock-widget))
(visibility-of widget))
Modified: trunk/src/uitoolkit/graphics/magick-core-api.lisp
==============================================================================
--- trunk/src/uitoolkit/graphics/magick-core-api.lisp (original)
+++ trunk/src/uitoolkit/graphics/magick-core-api.lisp Mon Jun 5 14:42:47 2006
@@ -135,7 +135,7 @@
(height :unsigned-long))
(defun scale-quantum-to-byte (quant)
- (floor (/ quant 257)))
+ (floor quant 257))
;;;
;;; translated from magick.h
Modified: trunk/src/uitoolkit/widgets/widget-utils.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget-utils.lisp (original)
+++ trunk/src/uitoolkit/widgets/widget-utils.lisp Mon Jun 5 14:42:47 2006
@@ -167,9 +167,9 @@
(setf baseline (+ b-width
top-margin
(gfg:ascent metrics)
- (floor (/ (- (gfs:size-height size)
- (+ (gfg:ascent metrics) (gfg:descent metrics)))
- 2)))))
+ (floor (- (gfs:size-height size)
+ (+ (gfg:ascent metrics) (gfg:descent metrics)))
+ 2))))
(gfs:dispose gc))
baseline))
@@ -190,8 +190,8 @@
(cffi:with-foreign-object (bm-ptr 'gfs::bitmap)
(cffi:with-foreign-slots ((gfs::width gfs::height) bm-ptr gfs::bitmap)
(gfs::get-object hbitmap (cffi:foreign-type-size 'gfs::bitmap) bm-ptr)
- (setf *check-box-size* (gfs:make-size :width (floor (/ gfs::width 4))
- :height (floor (/ gfs::height 3))))))
+ (setf *check-box-size* (gfs:make-size :width (floor gfs::width 4)
+ :height (floor gfs::height 3)))))
(gfs::delete-object hbitmap)))
(gfs:copy-size *check-box-size*))
Modified: trunk/src/uitoolkit/widgets/widget.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget.lisp (original)
+++ trunk/src/uitoolkit/widgets/widget.lisp Mon Jun 5 14:42:47 2006
@@ -41,7 +41,7 @@
(+ ancest-coord (floor (- (/ ancest-size 2) (/ desc-size 2)))))
(defun centered-coord-outside (ancest-coord ancest-size desc-size)
- (- ancest-coord (floor (/ (- desc-size ancest-size) 2))))
+ (- ancest-coord (floor (- desc-size ancest-size) 2)))
(defun center-object (ancestor descendant)
(let* ((ancest-size (client-size ancestor))
More information about the Graphic-forms-cvs
mailing list