Permalink
Browse files

partial tests as examples

  • Loading branch information...
1 parent 5164909 commit 5f32fd981a3e48334de1f42ce32b2d6a43204b16 @lisp committed Feb 22, 2010
Showing with 1,422 additions and 1 deletion.
  1. +1 −1 README.md
  2. BIN tests/.DS_Store
  3. +592 −0 tests/projection/abstract-projection.lisp
  4. +273 −0 tests/projection/clx.lisp
  5. +520 −0 tests/projection/opengl.lisp
  6. +36 −0 tests/tests.asd
View
2 README.md
@@ -44,7 +44,7 @@ Notes
- [CLX](http://www.x.org/wiki/) arc angles are degrees, view rotation is computed in radians. [@xfree](http://www.xfree86.org/current/XArc.3.html)
- [Java 3D] [rotations](http://java.sun.com/javase/technologies/desktop/java3d/forDevelopers/J3D_1_3_API/j3dapi/index.html) are radians
- [OpenGL](http://www.opengl.org/sdk/docs/man/xhtml/glRotate.xml) degrees
- - SVG : [transforms](http://www.w3.org/TR/SVG/coords.htm are degrees,
+ - SVG : [transforms](http://www.w3.org/TR/SVG/coords.htm) are degrees,
No one of them is preeminent. The internal transformation operators are implemented in radians and converted as required as arguments to
library functions. It would be possible to apply internalization/externailzation operators intrface arguments, but since the interface
View
BIN tests/.DS_Store
Binary file not shown.
View
592 tests/projection/abstract-projection.lisp
@@ -0,0 +1,592 @@
+;;; -*- Mode: LISP; Syntax: Common-lisp; Package: de.setf.object-graphics.implementation; Base: 10; Lowercase: Yes -*-
+
+
+(in-package :de.setf.graphics.implementation)
+
+(document :file
+ (description "This file defines bstract test for the 'de.setf.graphics' library.")
+ (copyright
+ "Copyright 2010 [james anderson](mailto:james.anderson@setf.de) All Rights Reserved"
+ "'de.setf.amqp' is free software: you can redistribute it and/or modify it under the terms of version 3
+ of the GNU Affero General Public License as published by the Free Software Foundation.
+
+ 'de.setf.graphics' is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the
+ implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+ See the Affero General Public License for more details.
+
+ A copy of the GNU Affero General Public License should be included with 'de.setf.graphics' as `DSG:agpl.txt`.
+ If not, see the GNU [site](http://www.gnu.org/licenses/).")
+
+ (history
+ (copyright 2003-2005 "[james anderson](mailto:james.anderson@setf.de)")
+ (delta 20050614 "collected abstract tests.")
+ (delta 20050620 "generalized tests to permit use for any context"))
+
+ (long-description "The `DSG:tests;projection;abstract-projection.lisp` file defines abstract tests for the
+ scene geometry elements. This file prepares the context necessary to invoke those tests against a CLX
+ device interface."))
+
+
+(defparameter *initial-view-position* (make-point 64 64))
+(defparameter *next-view-position* *initial-view-position*)
+(defparameter *max-view-height* 0)
+(defparameter *test-screen-size* (make-point 0 0))
+(defparameter *test-view-size* (make-point 320 320))
+(defparameter *test-view-placement* :tiled)
+(defparameter *test-sleep* 0.1)
+(defparameter *test-count* 10)
+(defun minimum-test-count () (or *test-count* 10))
+(defparameter *test-raster* nil)
+(defparameter *test-clear-color* #@(|3| .1 .1 .1))
+(defparameter *test-fill-color* #@(|3| .1 .1 .9))
+(defparameter *test-stroke-color* #@(|3| .9 .1 .1))
+(defvar *test-context* nil
+ "binds a global value for use with regression tests, each of which runs its test
+ wrapped within a with-projection-context ")
+(defparameter *test-projection-scale* #@(|3| 1.0 1.0 1.0))
+
+(defun identity-projection-context (&rest args)
+ "an identity projection context."
+ args)
+(defparameter *ipc* #'identity-projection-context)
+
+(defun test-raster ()
+ (or *test-raster*
+ (let ((data (make-array '(128 128) :element-type t :initial-element nil)))
+ (dotimes (i 128)
+ (dotimes (j 128)
+ (setf (aref data i j)
+ (let ((intensity (round (* 255 (/ i 128)))))
+ (make-list 3 :initial-element intensity)))))
+ (dotimes (x 128)
+ (let ((y (+ 64 (round (* 63 (sin (* 4 pi (/ x 128))))))))
+ (setf (aref data y x) (list (* x 2) 0 (- 255 (* x 2))))))
+ (setq *test-raster*
+ (make-instance 'raster :location (make-location-world :x 0.0d0 :y 0.0d0)
+ :sample-depth 32
+ :sample-data data)))))
+;;; (test-raster)
+
+(defgeneric scene-equalp (f1 f2)
+ (:method ((f1 list) (f2 list))
+ (if (eq (first f1) 'quote)
+ (setf f1 (second f1)))
+ (when (eq (first f2) 'quote)
+ (setf f2 (second f2)))
+ (or (and (null f1) (null f2))
+ (and f1 f2
+ (scene-equalp (first f1) (first f2))
+ (scene-equalp (rest f1) (rest f2)))))
+ (:method ((s1 symbol) (s2 symbol))
+ (eq s1 s2))
+ (:method ((s1 t) (s2 symbol))
+ (and s2 (boundp s2)
+ (let ((s2v (symbol-value s2)))
+ (and (not (eq s2v s2))
+ (scene-equalp s1 s2v)))))
+ (:method ((s1 symbol) (s2 t))
+ (and s1 (boundp s1)
+ (let ((s1v (symbol-value s1)))
+ (and (not (eq s1v s1))
+ (scene-equalp s1v s1)))))
+ (:method ((f1 t) (f2 t))
+ (equalp f1 f2))
+ ;; allow compiled function to match an expression
+ (:method ((s1 function) (s2 list))
+ (eql (first s2) 'function)))
+
+(defgeneric initialize-test-context (context &key clear-p)
+ (:method ((context t) &key (clear-p t))
+ (clear-agent *test-clear-color*)
+ (transform :projection :clear
+ :projection :scale *test-projection-scale*
+ :view :clear)
+ (when clear-p (clear-view))))
+
+(defun execute-graphics-tests (&key (pattern :og.**) (stream *trace-output*) (mode test:*test-unit-mode*))
+ (dolist (test (test:find-tests pattern))
+ (test:execute-test test :stream stream :mode mode)))
+
+
+(defun render-form-and-test (name op form &key (clear-p t) (context *projection-context*))
+ name
+ (with-projection-context (context)
+ (initialize-test-context context :clear-p clear-p)
+ (let ((result (funcall op)))
+ (flush-view)
+ (cond ((eq context *ipc*)
+ (scene-equalp result form))
+ (t t)))))
+
+(defmacro og::test (name form &rest args)
+ (let* ((render-args (when (consp name) (rest name)))
+ (name (if (consp name) (first name) name))
+ (docstring nil)
+ (op (gensym (string name))))
+ (when (stringp form)
+ (setf docstring form
+ form (pop args)))
+ `(test:test ,name
+ ,@(when docstring (list docstring))
+ (flet ((,op () ,form))
+ (render-form-and-test ',name #',op ',form ,@render-args))
+ :value t ,@args)))
+
+
+
+;;; clear the og.projection tests
+(setf (test:find-test "og.projection.**") nil)
+
+
+;;;
+;;; generic tests
+
+
+;;;
+;;; per geometric element
+
+(og::test og.projection.arc.1
+ (arc #@(|3| 0.0 0.0 0.0) 0.5 0.0 #.pi :clockwise '((path-effect :paint)
+ (path-constituents :lines)
+ (stroke-agent #@(|3| 0.5 0.0 0.0)))))
+
+(og::test og.projection.arc*2.1
+ (arc*2 -0.5 0.0 0.5 #.pi #.pi :clockwise (lambda (render)
+ (path-effect :paint)
+ (path-constituents :surfaces)
+ (fill-agent #@(|3| 0.5 0.0 0.0))
+ (funcall render)
+ (path-constituents :lines)
+ (stroke-agent #@(|3| 0.0 0.5 0.0))
+ (funcall render))))
+
+(og::test og.projection.arc*3.1
+ (arc*3 0.5 0.0 0.0 0.55 0.0 #.pi :clockwise '((path-effect :paint)
+ (path-constituents :lines)
+ (stroke-agent #@(|3| 0.0 0.0 0.5)))))
+
+
+(og::test og.projection.circle.1
+ (circle #@(|3| 0.1 0.0 0.0) 0.1 '((path-effect :paint)
+ (stroke-agent #@(|3| 0.5 0.0 0.0)))))
+
+(og::test og.projection.circle*2.1
+ (circle*2 0.2 0.1 0.2 '((path-effect :paint)
+ (path-constituents :surfaces)
+ (fill-agent #@(|3| 0.0 0.5 0.0)))))
+
+(og::test og.projection.circ3e*3.1
+ (circle*3 0.5 0.2 0.0 0.5 '((path-effect :paint)
+ (path-constituents :lines)
+ (stroke-agent #@(|3| 0.0 0.0 0.5)))))
+
+
+(og::test og.projection.line.1
+ (line #@(|3| 0.0 0.0 0.0) #@(|3| 0.1 0.0 0.0) '((path-effect :paint)
+ (stroke-agent #@(|3| 0.5 0.0 0.0)))))
+
+(og::test og.projection.line*2.1
+ (line*2 0.0 0.0 0.2 0.1 '((path-effect :paint)
+ (stroke-agent #@(|3| 0.0 0.5 0.0)))))
+
+(og::test og.projection.line*3.1
+ (line*3 0.0 0.0 0.0 0.5 0.2 0.0
+ '((path-effect :paint) (path-constituents :lines) (stroke-agent #@(|3| 0.0 0.0 0.5)))))
+
+
+(og::test og.projection.poly.1
+ (progn
+ (transform :projection :rotate 1.0 1.0 0.0)
+ (poly '(#@(|3| 0.0 0.0 0.0) #@(|3| 0.0 0.1 0.0) #@(|3| 0.1 0.1 0.0) #@(|3| 0.1 0.0 0.0)
+ #@(|3| 0.1 0.0 0.1) #@(|3| 0.1 0.1 0.1) #@(|3| 0.0 0.1 0.1) #@(|3| 0.0 0.0 0.1)
+ #@(|3| 0.0 0.0 0.0))
+ (lambda (render)
+ (path-effect :paint) (path-constituents :surfaces) (fill-agent #@(|3| 0.5 0.0 0.0)) (funcall render)
+ (path-constituents :lines) (stroke-agent #@(|3| 0.5 0.5 0.0)) (funcall render)))))
+
+(defun render-test-cube ()
+ (poly '(#@(|3| 0.0 0.0 0.0) #@(|3| 0.0 0.1 0.0) #@(|3| 0.1 0.1 0.0) #@(|3| 0.1 0.0 0.0)
+ #@(|3| 0.1 0.0 0.1) #@(|3| 0.1 0.1 0.1) #@(|3| 0.0 0.1 0.1) #@(|3| 0.0 0.0 0.1)
+ #@(|3| -0.5 -0.5 0.5) #@(|3| -0.5 0.5 0.5) #@(|3| 0.0 0.1 0.1)
+ #@(|3| 0.1 0.1 0.1) #@(|3| 0.5 0.5 0.5) #@(|3| 0.5 -0.5 0.5) #@(|3| 0.1 0.0 0.1)
+ #@(|3| 0.1 0.0 0.0) #@(|3| 0.5 -0.5 -0.5) #@(|3| 0.5 0.5 -0.5) #@(|3| 0.1 0.1 0.0)
+ #@(|3| 0.0 0.1 0.0) #@(|3| -0.5 0.5 -0.5) #@(|3| -0.5 -0.5 -0.5) #@(|3| 0.0 0.0 0.0)
+ #@(|3| 0.0 0.0 0.1))
+ (lambda (render)
+ (path-effect :paint) (path-constituents :surfaces) (fill-agent #@(|3| 0.5 0.0 0.0)) (funcall render)
+ (path-constituents :lines) (stroke-agent #@(|3| 0.5 0.5 0.0)) (funcall render))))
+
+(og::test og.projection.poly.2
+ (progn
+ (transform :projection :rotate 1.0 1.0 -0.2)
+ (render-test-cube)))
+
+(og::test og.projection.poly.3
+ (let ((delta (degrees-to-radians 5))
+ (base (degrees-to-radians 30)))
+ (transform :projection :rotate base base base)
+ (dotimes (x (floor (* (/ pi delta))))
+ (clear-view)
+ (render-test-cube) (flush-view )
+ (transform :projection :rotate delta delta delta))))
+
+
+(og::test og.projection.raster.0
+ (progn
+ (path-effect :paint)
+ ;; test that the raster and other geometry transform to the same spots
+ (line #@(|3| 1.0 -1.0 0.0) #@(|3| -1.0 1.0 0.0) '((stroke-agent #@(|3| 1.0 0.0 0.0))))
+ (line #@(|3| -1.0 -1.0 0.0) #@(|3| 1.0 1.0 0.0) '((stroke-agent #@(|3| 0.0 1.0 0.0))))
+ (raster #@(|3| 1.0 -1.0 0.0) #@(|3| -1.0 1.0 0.0) (test-raster) ())))
+
+(og::test og.projection.raster.1
+ (raster*2 -1.0 -1.0 0.0 0.0 (test-raster) ()))
+
+(og::test og.projection.raster*2.1
+ (raster*2 -0.5 -0.5 0.5 0.5 (test-raster) ()))
+
+(og::test og.projection.raster*3.1
+ (raster*3 -0.5 -0.25 -1.0 0.5 0.25 1.0 (test-raster) ()))
+
+
+(og::test og.projection.rectangle.1
+ (rectangle #@(|3| 0.0 0.0 0.0) #@(|3| 0.1 0.1 0.0) '((path-effect :paint)
+ (stroke-agent #@(|3| 0.5 0.0 0.0)))))
+
+(og::test og.projection.rectangle*2.1
+ (rectangle*2 0.0 0.0 0.2 0.1 '((path-effect :paint)
+ (path-constituents :surfaces)
+ (fill-agent #@(|3| 0.0 0.9 0.0)))))
+
+(og::test og.projection.rectangle*3.1
+ (rectangle*3 0.0 0.0 0.0 1.0 0.7 0.0 '((path-effect :paint)
+ (path-constituents :lines)
+ (stroke-agent #@(|3| 0.0 0.0 0.5)))))
+
+
+(og::test og.projection.text.1
+ (text #@(|3| 0.0 0.0 0.0) "testing one" :times-bold-10 '((stroke-agent #@(|3| 1.0 0.0 0.0)))))
+
+(og::test og.projection.text*2.1
+ (text*2 0.2 0.5 "testing two" :times-plain-10 '((stroke-agent #@(|3| 0.0 1.0 0.0)))))
+
+(og::test og.projection.text*3.1
+ (text*3 0.5 -0.5 0.0 "testing three" :times-bold-10 '((stroke-agent #@(|3| 0.0 0.0 1.0)))))
+
+
+(og::test og.projection.color*3.1
+ (fill-view (color*3 0.1 0.0 0.2)))
+
+(og::test og.projection.color*4.1
+ (fill-view (color*4 0.0 0.2 0.3 0.1)))
+
+(og::test og.projection.clear-view.1
+ (clear-view))
+
+(og::test og.projection.fill-view.1
+ (fill-view #@(|3| 0.0 0.1 0.2)))
+
+
+(og::test og.projection.transform.1
+ "test projection transforms - relative and assertion.
+ should produce a multi-colored 'X'."
+ (progn
+ (line*3 0.1 0.1 0.0 0.0 0.0 0.0 '((stroke-agent #@(|3| 1.0 0.0 0.0))))
+ (transform :projection :clear :scale (location-* #@(|3| -1.0 1.0 1.0) *test-projection-scale*))
+ (line*3 0.1 0.1 0.0 0.0 0.0 0.0 '((stroke-agent #@(|3| 0.0 1.0 0.0))))
+ (transform :projection :scale (location-* #@(|3| 1.0 -1.0 1.0) *test-projection-scale*))
+ (line*3 0.1 0.1 0.0 0.0 0.0 0.0 '((stroke-agent #@(|3| 0.0 0.0 1.0))))
+ (with-matrices ((lower-right 1.0 0.0 0.0 0.0
+ 0.0 -1.0 0.0 0.0
+ 0.0 0.0 1.0 0.0
+ 0.0 0.0 0.0 1.0))
+ (transform :projection :set lower-right)
+ (line*3 0.1 0.1 0.0 0.0 0.0 0.0 '((stroke-agent #@(|3| 1.0 1.0 1.0)))))
+ t))
+
+;;; there is no general test for this, as some systems implement a viewport transform
+;;; based on rectangle coordinates in the window-system's window and some based
+;;; on a transform. in the former case, the projection layer computes the effective
+;;; port rectangles coordinate by transforming [#@(-1 -1) #@(1 1)] and then normalizes to
+;;; #@(0 0), but that's not correct
+
+#+until-viewports-work-for-opengl
+(og::test og/projection/transform/2
+ "test view transforms - relative and assertion.
+ should produce a multi-colored 'X'."
+ (progn
+ (line*3 -1.0 -1.0 1.0 1.0 1.0 -1.0 '((stroke-agent #@(|4| 1.0 0.0 0.0 1.0))))
+ (line*3 1.0 -1.0 1.0 -1.0 1.0 -1.0 '((stroke-agent #@(|4| 1.0 0.0 0.0 1.0))))
+ (transform :view :clear :scale #@(|4| .75 .75 1.0))
+ (line*3 -1.0 -1.0 0.0 1.0 1.0 0.0 '((color-mode :blend) (stroke-agent #@(|4| 0.0 1.0 0.0 0.9))))
+ (line*3 1.0 -1.0 0.0 -1.0 1.0 0.0 '((color-mode :blend) (stroke-agent #@(|4| 0.0 1.0 0.0 0.9))))
+
+ (transform :view :clear :scale #@(|3| 0.5 0.5 0.0 0.0) :translate #@(|2| 0.0 08.0))
+ (line*3 -1.0 -1.0 0.0 1.0 1.0 0.0 '((stroke-agent #@(|3| 0.0 0.0 1.0))))
+ (line*3 1.0 -1.0 0.0 -1.0 1.0 0.0 '((stroke-agent #@(|3| 0.0 0.0 1.0))))
+ (with-matrices ((lower-right .5 0.0 0.0 0.0
+ 0.0 .5 0.0 0.0
+ 0.0 0.0 0.0 0.0
+ 128.0 0.0 0.0 0.0))
+ (transform :view :set lower-right)
+ (line*3 -1.0 -1.0 0.0 1.0 1.0 0.0 '((stroke-agent #@(|3| 0.0 0.0 0.0))))
+ (line*3 1.0 -1.0 0.0 -1.0 1.0 0.0 '((stroke-agent #@(|3| 0.0 0.0 0.0)))))
+ nil)
+ nil)
+
+
+
+;;;
+;;; various combined tests
+
+(defun test-color ()
+ (fill-view #@(|3| 1.0d0 0.0d0 0.0d0))
+ (line*2 1.0 1.0 -1.0 -1.0 '((stroke-agent #@(|3| 0.0 1.0 0.0))))
+ (line*2 1.0 -1.0 -1.0 1.0 '((stroke-agent #@(|3| 0.0d0 0.0d0 1.0d0))))
+ t
+ )
+
+(og::test og.projection.test-color.1
+ (test-color))
+
+
+(defun test-translated-rectangles (&key (count 10))
+ (let ((colors (make-array count)))
+ (dotimes (x count)
+ (let ((value (/ x (float count 1.0))))
+ (setf (aref colors x) (list 'color*3 value value value))))
+ (with-projection-variables
+ (lambda ()
+ (path-constituents :surfaces))
+ (dotimes (i count)
+ (let* ((center (- (* i .1) 0.45))
+ (min (- center 0.5))
+ (max (+ center 0.5)))
+
+ (with-projection-variables
+ (lambda () )
+ (fill-agent (aref colors i))
+ (rectangle*2 min min max max))
+ (flush-view)
+ (unless (eq *projection-context* *ipc*) (sleep *test-sleep*))
+ ))))
+ t)
+
+(og::test og.projection.translated-rectangles-test.1
+ (test-translated-rectangles))
+
+
+(defun test-projection-variables ()
+ (rectangle*3 -0.9d0 -0.9d0 0.0d0 0.9d0 0.9d0 0.0d0
+ (lambda (geometry)
+ (path-constituents :surfaces)
+ ;; (color-mode :blend :src-alpha :one-minus-src-alpha)
+ (fill-agent 1.0 1.0 1.0 1.0)
+ (funcall geometry)
+ (color-mode :opaque)
+ (stroke-agent 1.0 0.0 0.0 1.0)
+ (path-constituents :lines)
+ (funcall geometry)
+ ))
+ t)
+
+(og::test og.projection.projection-variables-test.1
+ (test-projection-variables))
+
+
+(defun test-simple-transformation ()
+ (let* ((from (make-location-world :x 10.0d0 :y 10.0d0))
+ (to (make-location-world :x 200.0d0 :y 100.0d0))
+ (radius*3 (location-/ (location-- to from)
+ (location-3 2.0 2.0 2.0 1.0)))
+ (count 10)
+ (radius (location-magnitude radius*3))
+ (delta (make-location-world :x (/ radius count)
+ :y (/ radius count)))
+ (-delta (location-* delta #@(|2| 1.0 -1.0))))
+ (stroke-agent 1.0 1.0 1.0)
+ (path-effect :paint)
+ (transform :projection :clear
+ :translate #@(|3| -1.0 -.5 0.0)
+ :scale #@(|3| .01 .01 .01))
+ ;; (raster (location-+ from delta) (location-- to from) *test-raster*)
+ (line from to '((fill-agent 1.0 0.0 0.0)))
+ (stroke-agent 1.0 0.0 0.0)
+ (rectangle from to '((fill-agent 0.0 1.0 0.0)
+ (path-constituents :lines)))
+ (stroke-agent 0.0 1.0 0.0)
+ (arc (location-/ (location-+ from to) (location-3 2.0 2.0 2.0 1.0))
+ radius 0.0 pi :clockwise)
+ (let* ((l (location-world (- (/ (+ (location-x from) (location-x to)) 2)
+ radius)
+ (/ (+ (location-y from) (location-y to)) 2)))
+ (l* (list l)))
+ (dotimes (x count)
+ (push (setf l (location-+ l delta)) l*)
+ (push (setf l (location-+ l -delta)) l*))
+ (poly l* '((path-constituents :lines) (stroke-agent 0.0 0.0 1.0))))
+ t))
+
+
+(og::test og.projection.test-simple-transformation.1
+ (test-simple-transformation))
+
+
+#+ignore
+(og::test og.projection.drawing-modes.1
+ (test-drawing-modes))
+
+(defun test-lines (&key (count (minimum-test-count)) (flush-p t))
+ (stroke-agent (random 1.0) (random 1.0) (random 1.0) .5s0)
+ (transform :projection :scale .01 .01 .01)
+ (dotimes (x count)
+ (line*3 -90.0 -90.0 0.0 90.0 90.0 0.0)
+ (when flush-p (flush-view)))
+ t)
+
+(og::test og.projection.test-lines.flushed
+ (test-lines))
+
+(og::test og.projection.test-lines.piped
+ (test-lines :count 1000 :flush-p nil))
+
+
+(defun test-lines-random (&key (count (minimum-test-count)) (flush-p t))
+ (dotimes (i count)
+ (dotimes (j count)
+ (let ((x (random 1.0))
+ (y (random 1.0))
+ (z (random 1.0d0)))
+ (stroke-agent x y z 1.0)
+ (line*3 (- (/ i count) 1.0) (- (/ j count) 1.0) z
+ (- (* x 2.0) 1.0) (- (* y 2.0) 1.0) z)
+ (when flush-p (flush-view))))
+ ;; always flush at least once pre pass - 10.4 otherwise shows the end result only
+ (unless flush-p (flush-view)))
+ t)
+
+
+(og::test og.projection.run-life.1
+ (run-life :cycles (minimum-test-count) :sleep nil :initialize-p nil))
+
+
+(defun test-sampler (&key (initialize-p t))
+ (when (or (null *life-raster*) initialize-p)
+ (initialize-life-raster))
+
+ (sampler :break-p nil
+ :clear-p #'(lambda ()
+ (stroke-agent 1.0 1.0 1.0)
+ (raster*2 -0.9 -0.9 0.9 0.9 *life-raster*)))
+ t)
+
+(og::test og.projection.sampler.1
+ (test-sampler))
+
+
+(defun test-sampler-animation (&key (count (minimum-test-count)) (sleep *test-sleep*) (initialize-p t)
+ (verbose-p nil))
+ "run the sampler function with an iteratively rotating coordinate system.
+ keyword parameters:
+ count: specifies iterations
+ sleep: specifies how long to sleep between iterations, or nil continuous."
+ (when (or (null *life-raster*) initialize-p)
+ (initialize-life-raster))
+ (dotimes (i (or count most-positive-fixnum))
+ (with-projection-variables
+ (lambda ()
+ (transform :projection :rotate (* i .1) 0.0 0.0))
+ (when verbose-p (format *trace-output* "~d " i))
+ (sampler :clear-p #'(lambda ()
+ (clear-view)
+ (stroke-agent 1.0 1.0 1.0)
+ (raster*2 -0.7 -0.7 0.7 0.7 *life-raster*)))
+ (flush-view)
+ (next-generation *life-raster*)
+ (when sleep (sleep sleep))))
+ t)
+
+(og::test og.projection.sampler.2
+ (test-sampler-animation :sleep nil))
+
+
+(og::test (og.version :clear-p nil)
+ (text*2 -0.98d0 -0.98d0 (format nil "~a~%~a~%~a"
+ (lisp-implementation-type)
+ (lisp-implementation-version)
+ (type-of *projection-context*))
+ :times-plain-10
+ '((stroke-agent "fuchsia"))))
+
+
+(find-rgba :fuchsia)
+;;;
+;;; pipelined v/s immediate performance
+#+(or )
+(progn
+
+ (with-projection-context ((test-context))
+ (with-monitoring-report (:stream #p"home:og-line-no-flush.html")
+ (dsu:time-and-memory
+ (test:execute-test (test-lines-random :count 1000 :flush-p nil)))))
+
+ (with-projection-context ((test-context))
+ (with-monitoring-report (:stream #p"home:tmp;og-line-flush.html")
+ ;; use time-and-memory to make it comparable with library-specific results
+ (dsu:time-and-memory
+ (test-lines-random :count 1000 :flush-p t)))))
+
+
+
+
+#|
+(defun compute-view-position (position
+ &key (screen-size #@(1024 768))
+ (view-size *test-view-size*))
+ (case position
+ (:fixed *initial-view-position*)
+ (:tiled (let ((screen-width (point-h screen-size))
+ (screen-height (point-v screen-size))
+ (x (point-h *next-view-position*))
+ (y (point-v *next-view-position*)))
+ (cond ((< (+ x (point-h view-size)) (* screen-width .67))
+ (setf position *next-view-position*))
+ (t
+ (setf x (point-h *initial-view-position*)
+ y (+ y *max-view-height*)
+ *max-view-height* 0)
+ (cond ((< (+ y (point-v view-size)) (* screen-height .67))
+ (setf position (make-point x y)))
+ (t
+ (setf y (point-v *initial-view-position*))
+ (setf position (make-point x y))))))
+ (setf *next-view-position*
+ (make-point (+ x (point-h view-size)) y))
+ (setf *max-view-height*
+ (max *max-view-height* (point-v view-size)))
+
+ position))
+ (t
+ (etypecase position
+ (integer position)))))
+
+
+(let ((pathname (make-pathname :host "home"
+ :name (multiple-value-bind (sec min hour day month year) (decode-universal-time (get-universal-time))
+ (format nil "functions-~4,'0d~2,'0d~2,'0dT~2,'0d~2,'0d~2,'0d" year month day hour min sec))
+ :type "dot"))
+ (count nil)
+ (de.setf.utility.implementation::*function-walk-depth-limit* 4))
+ (setf count (de.setf.utility.implementation::graph-functions :stream pathname :function 'line*3
+ :packages `(:og.impl :og)
+ ;; :packages (list-all-packages)
+ :depth-limit 4
+ :options '(:qualifiers (de.setf.utility.implementation::calls de.setf.utility.implementation::relations de.setf.utility.implementation::other))))
+ (ccl:set-mac-file-creator pathname (intern (make-string 4 :initial-element #\null) :keyword))
+ (setf pathname (namestring (truename pathname)))
+ (setf pathname (subseq pathname (1+ (position #\: pathname))))
+ (bsd:system-command (print (format nil "open '/~a'" (substitute #\/ #\: pathname))))
+ count)
+
+
+|#
View
273 tests/projection/clx.lisp
@@ -0,0 +1,273 @@
+;;; -*- Mode: LISP; Syntax: Common-lisp; Package: de.setf.graphics.implementation; Base: 10; Lowercase: Yes -*-
+
+(in-package :de.setf.graphics.implementation)
+
+(document :file
+ (description "This file defines test for the CLX interface for the 'de.setf.graphics' library.")
+ (copyright
+ "Copyright 2010 [james anderson](mailto:james.anderson@setf.de) All Rights Reserved"
+ "'de.setf.amqp' is free software: you can redistribute it and/or modify it under the terms of version 3
+ of the GNU Affero General Public License as published by the Free Software Foundation.
+
+ 'de.setf.graphics' is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the
+ implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+ See the Affero General Public License for more details.
+
+ A copy of the GNU Affero General Public License should be included with 'de.setf.graphics' as `DSG:agpl.txt`.
+ If not, see the GNU [site](http://www.gnu.org/licenses/).")
+
+ (history
+ (copyright 2003 "[james anderson](mailto:james.anderson@setf.de)")
+ (delta 20030918 ))
+
+ (long-description "The `DSG:tests;projection;abstract-projection.lisp` file defines abstract tests for the
+ scene geometry elements. This file prepares the context necessary to invoke those tests against a CLX
+ device interface."))
+
+
+(defvar *clx-c* nil)
+
+
+;;; the error "TCP-UNKNOWN-DOMAIN-NAME: Unknown host name. A bad endpoint name was supplied."
+;;; means the host is not set
+;;; the error "X-Error: Connection failure to X11.0 server 127.0.0.1 display 0: No protocol specified"
+;;; means authorization information is required. either the .Xauthority file was not found,
+;;; or no entry from it matched the specified host.
+;;; nb. under osx, the server generates a files which does not support local host over tcp
+;;; the entry night have been intended to be
+;;; localhost:0 MIT-MAGIC-COOKIE-1 ce437f51a50bbf13881d651f15ce3470
+;;; which xlib::get-best-authorization matches to neither a "localhost" nor a "127.0.0.1" display host,
+;;; as, in those cases, it coerces the protocol to :local, despite that the entry protocol is :internet
+;;; either use a proper host name, or disable display authentication.
+;;;
+;;; mcl defines #P"home:" to be the start-up directory, ofter the same as #P"ccl:". in this case,
+;;; set the XAUTHORITY environment variable or set a link from #4P"home:.Xauthority" to "~/.Xauthority".
+
+;;; for my 'localhost', either or
+(setq *clx-display-host* "yoda.setf.de")
+(setq *clx-display-host* "192.168.1.25")
+;;; or disable authorization
+;;; xhost +192.168.1.25
+
+
+;;; from clx-demos.lisp
+#+(or ) ; to reset/restart
+(progn
+ (ignore-errors (xlib:close-display *clx-default-display*))
+ (setq *clx-default-display* nil)
+ (setq *clx-c* nil))
+
+#+(or ) ; to start
+(initialize-clx-tests)
+
+(defun initialize-clx-tests ()
+ (unless *clx-default-display*
+ #+:cmu
+ (setq *clx-default-display* (ext:open-clx-display))
+ #+(or sbcl openmcl)
+ (setf *clx-default-display* (xlib::open-default-display))
+ #-(or cmu sbcl openmcl)
+ ;; Portable method
+ (setq *clx-default-display* (xlib:open-display *clx-display-host*
+ :display *clx-display-number*
+ :protocol :internet))
+ )
+
+ ;; no (setf (context-view *clx-c*) *clc-w*)
+ (setq *clx-c* (make-instance 'clx-context :display *clx-default-display*
+ :view-size *test-view-size*))
+ (setq *test-context* *clx-c*)
+ )
+
+
+(defmethod initialize-test-context ((context clx-context) &key &allow-other-keys)
+ (let ((size (context-size context)))
+ (call-next-method)
+ (transform :view
+ :translate (/ (point-h size) 2) (/ (point-v size) 2) 0.0
+ :scale (/ (point-h size) 2) (/ (point-v size) -2) 0.0)
+ (context-log-message context 'initialize-test-state "~W" (context-state context))
+ ))
+
+
+(defun clx-test-context ()
+ (or *clx-c*
+ (initialize-clx-tests)))
+
+
+(defmacro og::test-clx (name form &rest args)
+ (let ((render-args (when (consp name) (rest name)))
+ (name (if (consp name) (first name) name))
+ (docstring nil))
+ (when (stringp form)
+ (setf docstring form
+ form (pop args)))
+ `(og::test (,name :context (clx-test-context) ,@render-args)
+ ,@(when docstring (list docstring))
+ ,form
+ ,@args)))
+
+
+
+;;; just to check
+#+mcl
+(test:test og.clx.endian
+ (ccl:rlet ((data :rect))
+ (setf (ccl:%get-long data) #x01020304)
+ (ecase (+ (* (ccl:%get-byte data 0) 1000)
+ (* (ccl:%get-byte data 1) 100)
+ (* (ccl:%get-byte data 2) 10)
+ (ccl:%get-byte data 3))
+ (1234 (not (find :clx-little-endian *features*)))
+ (4321 (find :clx-little-endian *features*)))))
+;; (test:execute-test :og.clx.endian)
+
+
+(og::test-clx og.clx.ffi
+ "test direct xlib interface operators"
+ (progn
+ (assert (typep *projection-context* 'clx-context))
+ (let* ((context *projection-context*)
+ (view (context-view context))
+ (size (context-size context))
+ (width (point-h size))
+ (height (point-v size)))
+ ;; (print (context-state))
+ (xlib:clear-area view)
+ ;; (sleep 1)
+ (xlib:draw-rectangle view *clx-gcontext*
+ 4 4 (- width 8) (- height 8)
+ t)
+ (setf (xlib:gcontext-foreground *clx-gcontext*)
+ (nth-value 1 (clx-fill-agent*3 0.0 1.0 1.0)))
+ (xlib:draw-line view *clx-gcontext* 0 (point-v size) (point-h size) 0 nil)
+ (setf (xlib:gcontext-foreground *clx-gcontext*)
+ (nth-value 1 (clx-fill-agent*3 1.0 0.0 1.0)))
+ (xlib:draw-line view *clx-gcontext* 0 0 (point-h size) (point-v size) nil)
+ (xlib:display-force-output *clx-default-display*)
+ (let* ((1w (floor (/ width 8)))
+ (1h (floor (/ height 8))))
+ (setf (xlib:gcontext-foreground *clx-gcontext*)
+ (nth-value 1 (clx-fill-agent*3 1.0 0.0 0.0)))
+ ;; clockwise
+ (xlib:draw-lines view *clx-gcontext*
+ (list 1w (- height 1h)
+ 1w 1h
+ (- width 1w) 1h
+ (- width 1w) (- height 1h))
+ :fill-p t)
+ (setf (xlib:gcontext-foreground *clx-gcontext*)
+ (nth-value 1 (clx-fill-agent*3 0.0 1.0 0.0)))
+ ;; counter-clockwise
+ (let ((1w (* 1w 2))
+ (1h (* 1h 2)))
+ (xlib:draw-lines view *clx-gcontext*
+ (list 1w (- height 1h)
+ (- width 1w) (- height 1h)
+ (- width 1w) 1h
+ 1w 1h)
+ :fill-p t))
+
+ (setf (xlib:gcontext-foreground *clx-gcontext*)
+ (nth-value 1 (clx-fill-agent*3 0.0 0.0 1.0)))
+ ;; clockwise frame - needs an extra point
+ (let ((1w (* 1w 3))
+ (1h (* 1h 3)))
+ (xlib:draw-lines view *clx-gcontext*
+ (list 1w (- height 1h)
+ 1w 1h
+ (- width 1w) 1h
+ (- width 1w) (- height 1h)
+ 1w (- height 1h))
+ :fill-p nil))
+ ;; (print (context-state))
+ t))))
+;; (test:execute-test :og.clx.ffi)
+
+
+(og::test-clx og.clx.context.size
+ "check the view size accessors"
+ (let ((width (xlib:drawable-width *context-view*))
+ (height (xlib:drawable-height *context-view*))
+ (size (context-size *projection-context*)))
+ (and (eql width (point-h size))
+ (eql height (point-v size)))))
+
+
+(og::test-clx og.clx.context.line
+ "draw progressive lines over the top-left quadrangle"
+ (progn
+ ;; reset the transforms to reinstate port coordinates
+ (transform :projection :clear :view :clear)
+ (let* ((size (context-size *projection-context*))
+ (width (point-h size))
+ (height (point-v size))
+ (c1 (/ width 2))
+ (c2 height)
+ (from (make-location-world :x 0.0d0 :y 0.0d0))
+ (to (make-location-world :x c1 :y c2)))
+ (line from to)
+ (setf (location-x to) c2 (location-y to) c1)
+ (line from to)
+ (flush-view)
+ (sleep *test-sleep*)
+ (dotimes (i (floor c1) c1)
+ (line*2 0 0 i c1)
+ (line*2 0 0 c1 i)
+ ;; let it appear sort of incrementally
+ (flush-view)))))
+;; (test:execute-test :og.clx.context.line :break-on-signals t)
+
+
+(og::test-clx og.clx.context.rectangle
+ "draw progressive rectangles over the top-left quadrangle"
+ (progn
+ ;; reset the transforms to reinstate port coordinates
+ (transform :projection :clear :view :clear)
+ (let* ((size (context-size *projection-context*))
+ (width (point-h size))
+ (height (point-v size))
+ (c1 (/ width 2))
+ (c2 height)
+ (from (make-location-world :x 0.0d0 :y 0.0d0))
+ (to (make-location-world :x c1 :y c2)))
+ (line from to)
+ (setf (location-x to) c2 (location-y to) c1)
+ (line from to)
+ (flush-view)
+ (sleep *test-sleep*)
+ (dotimes (i (floor c1) c1)
+ (rectangle*2 0 0 i c1 nil)
+ (rectangle*2 0 0 c1 i nil)
+ ;; let it appear sort of incrementally
+ (flush-view)))))
+;; (test:execute-test :og.clx.context.rectangle)
+
+
+;;; run all tests for clx and those from abstract-projection
+;;;
+;;; (test:find-tests :og.clx.**)
+
+(defun execute-graphics-clx-tests ()
+ (clx-test-context) ; ensure there is one
+ (test:execute-test :og.clx.**)
+ (with-projection-context (*clx-c*) (test:execute-test :og.projection.**))
+ (with-projection-context (*clx-c*)
+ (test:execute-test :og.projection.sampler.1)
+ (test:execute-test :og.version)))
+
+;;; iff there already is one
+
+(when (typep *clx-c* 'clx-context)
+ (execute-graphics-clx-tests))
+
+
+
+;; (with-projection-context (*clx-c*) (test:execute-test :og.projection.poly.3 :break-on-signals t))
+;; (with-projection-context (*clx-c*) (xlib:screen-root-depth *clx-screen*))
+;; (with-projection-context (*clx-c*) (xlib:drawable-depth (context-view *clx-c*)))
+;; (with-projection-context (*clx-c*) (test-color))
+;; (with-projection-context (*clx-c*) (test-sampler-animation :count 2 :sleep .01))
+;; (time (with-projection-context (*clx-c*) (test-sampler-animation :count 100 :sleep nil)))
+
+
View
520 tests/projection/opengl.lisp
@@ -0,0 +1,520 @@
+;;; -*- Mode: LISP; Syntax: Common-lisp; Package: de.setf.graphics.implementation; Base: 10; Lowercase: Yes -*-
+
+(in-package :de.setf.graphics.implementation)
+
+(document :file
+ (description "This file defines test for the OpenGL interface for the 'de.setf.graphics' library.")
+ (copyright
+ "Copyright 2010 [james anderson](mailto:james.anderson@setf.de) All Rights Reserved"
+ "'de.setf.amqp' is free software: you can redistribute it and/or modify it under the terms of version 3
+ of the GNU Affero General Public License as published by the Free Software Foundation.
+
+ 'de.setf.graphics' is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the
+ implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+ See the Affero General Public License for more details.
+
+ A copy of the GNU Affero General Public License should be included with 'de.setf.graphics' as `DSG:agpl.txt`.
+ If not, see the GNU [site](http://www.gnu.org/licenses/).")
+
+ (history
+ (copyright 2003 "[james anderson](mailto:james.anderson@setf.de)")
+ (delta 20030921 ))
+
+ (long-description "The `DSG:tests;projection;abstract-projection.lisp` file defines abstract tests for the
+ scene geometry elements. This file prepares the context necessary to invoke those tests against an OpenGL
+ device interface."))
+
+
+(defparameter *gl-w* nil)
+(defparameter *gl-c* nil)
+
+#+( or) ; to start
+(initialize-opengl-tests)
+
+
+(defun initialize-opengl-tests ()
+ (setq *gl-c* (make-instance 'opengl-context))
+ (setf (context-get *gl-c* :window-title) "OpenGL"
+ (context-get *gl-c* :view-size) *test-view-size*
+ (context-get *gl-c* :view-position) (make-point 64 64)
+ )
+
+ (setq *gl-w* (make-instance *class.projection-context-window*
+ :window-title "OpenGL"
+ :view-size #@(256 256)
+ :view-position #@(100 100)
+ :window-layer 1))
+
+
+ (setf (context-view *gl-c*) *gl-w*)
+ (setf (view-context *gl-w*) *gl-c*)
+
+ (define-font *gl-c* '("Times" :plain 10) :times-plain-10)
+ (define-font *gl-c* '("Courier" :plain 10) :courier-plain-10)
+ (define-font *gl-c* '("Times" :bold 10) :times-bold-10)
+ *gl-c*)
+
+
+(defmethod initialize-test-context ((context opengl-context) &key &allow-other-keys)
+ (call-next-method)
+ (context-log-message context 'initialize-test-state "~W" (context-state context)))
+
+
+(defun opengl-test-context ()
+ (or *gl-c*
+ (initialize-opengl-tests)))
+
+
+
+(defmacro og::test-opengl (name form &rest args)
+ (let ((render-args (when (consp name) (rest name)))
+ (name (if (consp name) (first name) name))
+ (docstring nil))
+ (when (stringp form)
+ (setf docstring form
+ form (pop args)))
+ `(og::test (,name :context (opengl-test-context) ,@render-args)
+ ,@(when docstring (list docstring))
+ ,form
+ ,@args)))
+
+;;; direct ffi example from the opengl documentation
+
+(og::test-opengl og.opengl.ffi
+ (progn
+ (assert (typep *gl-c* 'opengl-context))
+ ;; (print (context-state))
+ (#_glClearColor 0.0s0 0.0s0 0.0s0 0.0s0)
+ (#_glClear GL:GL_COLOR_BUFFER_BIT)
+ (#_glOrtho -1.0 1.0 -1.0 1.0 -1.0 1.0)
+ (print (context-state))
+ ;; clockwise fill
+ (#_glColor3f 1.0s0 0.0s0 0.0s0)
+ (#_GLPolygonMode GL:GL_FRONT GL:GL_FILL)
+ (#_GLPolygonMode GL:GL_BACK GL:GL_POINT)
+ (#_glBegin GL:GL_POLYGON)
+ (#_glVertex2f -0.75s0 -0.75s0)
+ (#_glVertex2f 0.75s0 -0.75s0)
+ (#_glVertex2f 0.75s0 0.75s0)
+ (#_glVertex2f -0.75s0 0.75s0)
+ (#_glEnd)
+ ;; counter-clockwise points
+ (#_glColor3f 0.0s0 1.0s0 0.0s0)
+ (#_glBegin GL:GL_POLYGON)
+ (#_glVertex2f -0.5s0 -0.5s0)
+ (#_glVertex2f -0.5s0 0.5s0)
+ (#_glVertex2f 0.5s0 0.5s0)
+ (#_glVertex2f 0.5s0 -0.5s0)
+ (#_glEnd)
+ ;; clockwise frame
+ (#_glColor3f 0.0s0 0.0s0 1.0s0)
+ (#_GLPolygonMode GL:GL_FRONT GL:GL_LINES)
+ (#_glBegin GL:GL_POLYGON)
+ (#_glVertex2f -0.25s0 -0.25s0)
+ (#_glVertex2f 0.25s0 -0.25s0)
+ (#_glVertex2f 0.25s0 0.25s0)
+ (#_glVertex2f -0.25s0 0.25s0)
+ (#_glEnd)
+ (#_glFlush)
+ t))
+;; (test:execute-test :og.opengl.ffi)
+
+
+;;;
+;;; regression tests
+
+;;; simple
+
+(og::test-opengl og.opengl.context.elements.1
+ (progn
+ ;; w/o initialization - check what constituents are
+ (line #@(|3| -0.9 -0.9 0.0) #@(|3| 0.9 0.9 0.0) '((stroke-agent 1.0s0 0.0s0 0.0s0 .1s0)
+ (fill-agent 0.0s0 1.0s0 0.0s0 .1s0)
+ (clear-agent 0.0s0 0.0s0 1.0s0 .1s0)))
+ (rectangle #@(|3| -0.9 -0.9 0.0) #@(|3| 0.9 0.9 0.0) '((stroke-agent 0.0s0 1.0s0 0.0s0 .1s0)
+ (fill-agent 0.0s0 0.0s0 1.0s0 .1s0)
+ (clear-agent 1.0s0 0.0s0 0.0s0 .1s0)))
+ (circle #@(|3| 0.0 0.0 0.0) 0.9 '((stroke-agent 0.0s0 0.0s0 1.0s0 .1s0)
+ (fill-agent 1.0s0 0.0s0 0.0s0 .1s0)
+ (clear-agent 0.0s0 1.0s0 0.0s0 .1s0)))
+
+ t))
+;; (test:execute-test :og.opengl.context.elements.1)
+
+
+(og::test-opengl og.opengl.context.elements.2
+ (progn
+ (line #@(|3| -0.9 -0.9 0.0) #@(|3| 0.9 0.9 0.0) '((stroke-agent 1.0s0 0.0s0 0.0s0 .1s0)))
+ (line #@(|3| -0.9 0.9 0.0) #@(|3| 0.9 -0.9 0.0) '((stroke-agent #@(|3| 0 1 0))))
+ (arc #@(|3| 0.0 0.0 0.0) .3 #.pi 0.0 :clockwise '((stroke-agent #@(|3| 0.0 1.0 0.0))))
+ (arc #@(|3| 0.0 0.0 0.0) .3 0.0 #.pi :clockwise '((stroke-agent #@(|3| 1.0 0.0 0.0))))
+ (arc #@(|3| 0.0 0.0 0.0) .2 #.pi 0.0 :clockwise '((path-effect :clear)
+ (path-constituents :surfaces)))
+ (arc #@(|3| 0.0 0.0 0.0) .2 0.0 #.pi :clockwise '((stroke-agent #@(|3| 1.0 1.0 1.0))
+ (path-constituents :lines)
+ (path-effect :paint)))
+ (arc #@(|3| 0.0 0.0 0.0) .1 #.pi 0.0 :clockwise '((stroke-agent #@(|3| 0.0 0.0 1.0))
+ ))
+ (arc #@(|3| 0.0 0.0 0.0) .1 #.pi 0.0 :clockwise (lambda (geometry)
+ (fill-agent #@(|3| 1.0 0.0 1.0))
+ (path-constituents :surfaces)
+ (funcall geometry)
+ (stroke-agent #@(|3| 1.0 0.0 0.0))
+ (path-constituents :lines)
+ (funcall geometry)))
+ t))
+;; (test:execute-test :og.opengl.context.elements.2)
+
+
+
+;;;
+;;; timing comparison eliminating abstraction levels
+;;; 926 : 842 : 839
+
+;;; generic calls
+
+
+(defun gl-test-lines-random.generic (&key (count (minimum-test-count)) (flush-p t))
+ (dotimes (i count)
+ (dotimes (j count)
+ (let ((x (random 1.0))
+ (y (random 1.0))
+ (z (random 1.0d0)))
+ (stroke-agent x y z 1.0)
+ ;; use gl-specifc but argument-generic interface
+ (line*3 (- (/ i count) 1.0) (- (/ j count) 1.0) z
+ (- (* x 2.0) 1.0) (- (* y 2.0) 1.0) z)
+ (when flush-p (opengl-flush-view))))
+ ;; always flush at least once pre pass - 10.4 otherwise shows the end result only
+ (unless flush-p (opengl-flush-view)))
+ t)
+
+(og::test-opengl og.opengl.context.lines-random.generic
+ (with-projection-context (*gl-c*) (gl-test-lines-random.generic)))
+;; (time (test:execute-test :og.opengl.context.lines-random.generic))
+
+
+;;; strictly opengl calls
+
+(defun gl-test-lines-random.opengl (&key (count (minimum-test-count)) (flush-p t))
+ (dotimes (i count)
+ (dotimes (j count)
+ (let ((x (random 1.0))
+ (y (random 1.0))
+ (z (random 1.0d0)))
+ (opengl-stroke-color*4 x y z 1.0)
+ ;; use gl-specifc but argument-generic interface
+ (opengl-line*3 (- (/ i count) 1.0) (- (/ j count) 1.0) z
+ (- (* x 2.0) 1.0) (- (* y 2.0) 1.0) z)
+ (when flush-p (opengl-flush-view))))
+ ;; always flush at least once pre pass - 10.4 otherwise shows the end result only
+ (unless flush-p (opengl-flush-view)))
+ t)
+
+(og::test-opengl og.opengl.context.lines-random.opengl
+ (with-projection-context (*gl-c*) (gl-test-lines-random.opengl)))
+;; (time (test:execute-test :og.opengl.contextlines-random.opengl))
+
+
+
+;;; strictly opengl ff calls
+
+(defun gl-test-lines-random.ffi (&key (count (minimum-test-count)) (flush-p t))
+ (rlet ((%new-color :opengl-color4d :alpha 1.0d0))
+ (dotimes (i count)
+ (dotimes (j count)
+ (let ((x (random 1.0d0))
+ (y (random 1.0d0))
+ (z (random 1.0d0)))
+ (setf (rref %new-color opengl-color4d.red) x
+ (rref %new-color opengl-color4d.green) y
+ (rref %new-color opengl-color4d.blue) z)
+ (#_GLColor4dv %new-color)
+ (#_glBegin GL:GL_LINES)
+ (#_glVertex3d (- (/ i count) 1.0) (- (/ j count) 1.0) z)
+ (#_glVertex3d (- (* x 2.0) 1.0) (- (* y 2.0) 1.0) z)
+ (#_glEnd)
+ )
+ (when flush-p
+ (#_GLFlush)
+ (gl:aglSwapbuffers *opengl-glcontext*)
+ ))
+ (unless flush-p
+ (#_GLFlush)
+ (gl:aglSwapbuffers *opengl-glcontext*)
+ )))
+ t)
+
+(og::test-opengl og.opengl.context.lines-random.ffi
+ (with-projection-context (*gl-c*) (gl-test-lines-random.ffi)))
+;; (time (test:execute-test :og.opengl.context.lines-random.ffi))
+
+
+
+
+
+
+(defun gl-test-geometry ()
+ (let* ((from (make-location-world :x 10.0d0 :y 10.0d0))
+ (to (make-location-world :x 200.0d0 :y 100.0d0))
+ (radius*3 (location-/ (location-- to from)
+ (location-3 2.0 2.0 2.0 1.0)))
+ (count 10)
+ (radius (location-magnitude radius*3))
+ (delta (make-location-world :x (/ radius count)
+ :y (/ radius count)))
+ (-delta (location-* delta #@(|2| 1.0 -1.0)))
+ (size (view-size (context-view *projection-context*))))
+ (#_GLViewport 0 0 (point-h size) (point-v size))
+ (transform :projection :translate -1.0 -1.0 0.0
+ :scale (/ 2.0 (point-h size)) (/ 2.0 (point-v size)) 1.0)
+ (clear-agent .75 .75 .75)
+ (clear-view)
+ (raster (location-+ from delta) (location-- to from) *test-raster*)
+ (line from to '((stroke-agent 1.0 0.0 0.0)))
+ (rectangle from to '((stroke-agent 0.0 1.0 0.0)
+ (path-effect :invert)))
+ (path-constituents :lines)
+ (arc (location-/ (location-+ from to) (location-3 2.0 2.0 2.0 1.0))
+ radius
+ 0.0 pi :counterclockwise)
+ (let* ((l (location-world (- (/ (+ (location-x from) (location-x to)) 2)
+ radius)
+ (/ (+ (location-y from) (location-y to)) 2)))
+ (l* (list l)))
+ (dotimes (x count)
+ (push (setf l (location-+ l delta)) l*)
+ (push (setf l (location-+ l -delta)) l*))
+ (poly l* '((stroke-agent 0.0s0 0.0s0 1.0s0) (path-constituents :lines)))))
+ t)
+
+(og::test-opengl og.opengl.context.geometry
+ (with-projection-context (*gl-c*) (gl-test-geometry)))
+;; (test:execute-test :og.opengl.context.geometry)
+
+;;; run all tests for opengl and those from abstract-projection
+;;;
+;;; (test:find-tests :og.opengl.**)
+
+(defun execute-graphics-opengl-tests ()
+ (opengl-test-context) ; ensure that there is one
+ (test:execute-test :og.opengl.**)
+ (with-projection-context (*gl-c*) (test:execute-test :og.projection.**))
+ (with-projection-context (*gl-c*)
+ (test:execute-test :og.projection.sampler.1)
+ (test:execute-test :og.version)))
+
+
+;;; iff there already is one
+
+(when (typep *gl-c* 'opengl-context)
+ (execute-graphics-opengl-tests))
+
+
+;; (with-projection-context (*gl-c*) (test:execute-test :og.projection.sampler.1 :break-on-signals t))
+
+
+#|
+
+;;;
+;;; extended primitive tests
+
+(defClass opengl-test-window (context-window)
+ ((draw-function :initform nil :accessor window-draw-function)))
+
+(defMethod ccl:view-draw-contents ((view opengl-test-window))
+ (with-slots (draw-function) view
+ (when draw-function (funcall draw-function view))))
+
+
+(defun new-test-window (&key (view-size *test-view-size*)
+ (view-position #@(256 256))
+ (window-title "OpenGL")
+ (window-layer 1)
+ (window-show t)
+ (window-class opengl-test-window)
+ &aux w)
+ (setf w (make-instance window-class :color-p t
+ :view-size view-size
+ :view-position view-position
+ :window-title window-title
+ :window-layer window-layer
+ :window-show window-show))
+ (ccl:process-allow-schedule) ; let the default clear run
+ w)
+
+(defun test-gl-projection (function
+ &key (view-size *test-view-size*)
+ ((:window *gl-w*)
+ (or (when (and *gl-w* (ccl:wptr *gl-w*)) *gl-w*)
+ (setq *gl-w*
+ (new-test-window :view-size view-size
+ :window-class 'opengl-test-window))))
+ (invalidate-p t)
+ (immediate-p t)
+ (stream *trace-output*))
+ (format stream "~%projecting ~s -> ~s" *gl-c* *gl-w*)
+ (cond (immediate-p
+ (setf (context-view *gl-c*) *gl-w*)
+ (call-with-projection-context function *gl-c*))
+ (t
+ (setf (window-draw-function *gl-w*)
+ #'(lambda (view)
+ (setf (context-view *gl-c*) view)
+ (call-with-projection-context function *gl-c*)))
+ (when invalidate-p (ccl:invalidate-view *gl-w*))))
+ t)
+
+(setq *display-function*
+ #'(lambda (w &aux (time 0))
+ w
+ (when *display-time-p* (setf time (get-internal-run-time)))
+ ; (glClearColor 0.0 0.0 0.0 1.0)
+ (glClear (logior GL_COLOR_BUFFER_BIT gl_depth_buffer_bit))
+ (let* ((color (list 'glcolor3d 0.0 0.0 0.0))
+ (color-properties (list color)))
+ (dotimes (i 100)
+ (let ((x (/ i 100.0)))
+ (setf (second color) x)
+ (line3 x 0.0 0.0 0.0 1.0 0.0 color-properties)))
+ (setf (second color) 0.0)
+ (dotimes (i 100)
+ (let ((x (/ i 100.0)))
+ (setf (third color) x)
+ (line2 ( - x) 0.0 0.0 -1.0 color-properties)))
+
+ ; rect2
+ (let ((colors (make-array 10)))
+ (dotimes (x 10)
+ (setf (aref colors x)
+ (list (random 1.0) (random 1.0) (random 1.0))))
+ (glpushattrib GL_POLYGON_BIT)
+ (glpolygonMode GL_FRONT GL_FILL)
+ (glpolygonMode GL_BACK GL_FILL)
+ (glmatrixmode gl_modelview)
+ (glpushmatrix)
+ (gltranslated -1.0 0.0 0.0)
+ (glscaled .1 .1 .1)
+ (flet ((rect-props (glop)
+ (apply #'glcolor3d (aref colors (floor (random 10))))
+ (funcall glop)))
+ (declare (dynamic-extent #'rect-props))
+ (dotimes (x 10)
+ (dotimes (y 10)
+ (rect2 x y (1+ x) (1+ y) #'rect-props))))
+ (glpopmatrix)
+ (glpopattrib))
+ (glpushattrib GL_POLYGON_BIT)
+ (glpolygonMode GL_FRONT GL_LINE)
+ (glpolygonMode GL_BACK GL_LINE)
+ (dotimes (i 100)
+ (let ((x (/ i 100.0)))
+ (setf (fourth color) x)
+ (rect2 (- x) (- x) (- (+ x .25)) (- (+ x .25)) color-properties)))
+ (glpopattrib)
+
+ ; rect3 blended and transformed
+ (rect3 -1 -1 0 -2 0 0 `((glmatrixmode ,gl_modelview) (glpushmatrix)
+ (glscaled .5 .5 .5) (gltranslated .5 -.5 0.0)
+ (glpushattrib ,GL_POLYGON_BIT)
+ (glpolygonMode ,GL_FRONT ,GL_FILL)
+ (glpolygonMode ,GL_BACK ,GL_FILL)
+ (glEnable ,GL_BLEND)
+ (glBlendFunc ,GL_SRC_ALPHA ,GL_ONE_MINUS_SRC_ALPHA)
+ (glColor4d .75 .75 .75 .5)
+ (glop)
+ (glDisable ,GL_BLEND)
+ (glColor4d .25 .25 .25 1.0)
+ (glpolygonMode ,GL_FRONT ,GL_LINE)
+ (glpolygonMode ,GL_BACK ,GL_LINE)
+ (glop)
+ (glpopattrib)
+ (glpopmatrix)))
+
+ ;arc2
+ (glpushattrib GL_POLYGON_BIT)
+ (glpolygonMode GL_FRONT GL_LINE)
+ (glpolygonMode GL_BACK GL_LINE)
+ (dotimes (x 20)
+ (arc2 .5 -.5 (/ .5 (1+ x))
+ pi (* 2 pi) `((glcolor3d .5 ,(+ .5 (/ .5 (1+ x))) .5))))
+ (glpopattrib)
+
+ ;arc3
+ (glpushattrib GL_POLYGON_BIT)
+ (glpolygonMode GL_FRONT GL_FILL)
+ (glpolygonMode GL_BACK GL_FILL)
+ (dotimes (x 20)
+ (if (evenp x)
+ (glcolor3d 1.0 1.0 1.0)
+ (glcolor3d 0.0 0.0 0.0))
+ (arc3 .5 (/ -.5 (1+ x)) 0.0 (/ .5 (1+ x))
+ (if (evenp x) 0.0 pi) (if (evenp x) pi (* 2 pi))))
+ (glpopattrib)
+
+ ;; polyline
+ (let ((value (second (aref sin-values (1- (length sin-values))))))
+ (map nil #'(lambda (v) (rotatef (second v) value))
+ sin-values))
+ (glcolor3d 0.0 0.0 1.0)
+ (glpushattrib GL_POLYGON_BIT)
+ (glpolygonMode GL_FRONT GL_LINE)
+ (glpolygonMode GL_BACK GL_LINE)
+ (polyline2 sin-values)
+ (glpopattrib)
+
+ ; axes
+ (glcolor3d .7 .7 .7)
+ (line2 -1 0 1 0)
+ (line2 0.0 -1.0 0.0 1.0)
+ (do ((x -1.0 (+ x .1)))
+ ((> x 1.0))
+ (line2 x 0.0 x .1)
+ (line2 0.0 x .1 x))
+ ; text2
+ (text2 0.0 -1.0 "(0.0,-1.0)" :times-bold-10)
+
+ ; text3
+ (text3 0.0 .5 -1.0 "(0.0,.5,-1.0)" :times-bold-10)
+
+ ;; bounds
+ (rect2 -1 -1 1 1 `((glpushattrib ,GL_POLYGON_BIT)
+ (glpolygonMode ,GL_FRONT ,GL_LINE)
+ (glpolygonMode ,GL_BACK ,GL_LINE)
+ (glEnable ,GL_LINE_STIPPLE)
+ (glLineStipple 1 #b1010101010101010)
+ (glop)
+ (glDisable ,GL_LINE_STIPPLE)
+ (glpopattrib)))
+
+ (when *display-time-p*
+ (format *trace-output* "~%display: ~s"
+ (- (get-internal-run-time) time)))
+ )))
+
+
+;;; ideosyncratics
+
+(context-state *gl-c*)
+(with-projection-context (*gl-c*) (time (opengl-clear)))
+(with-projection-context (*gl-c*) (time (opengl-set-color *opengl-background-color*)))
+(with-projection-context (*gl-c*) (time (opengl-set-color #.(location-vector 0.0 0.0 0.0 0.0))))
+(with-projection-context (*gl-c*) (time (opengl-get-color *opengl-background-color*)))
+(with-projection-context (*gl-c*) (rt::time-and-memory (opengl-fill-view *opengl-background-color*)))
+(with-projection-context (*gl-c*) (gl:gldrawbuffer GL:GL_FRONT) (agl-error-check))
+(with-projection-context (*gl-c*) (gl:gldrawbuffer GL:GL_BACK) (agl-error-check))
+(with-projection-context (*gl-c*) (#_GLGetError))
+(with-projection-context (*gl-c*)
+ (let* ((color (rgba 0.0 0.0 0.0))
+ (fill-properties `((path-constituents :surfaces) (fill-agent ,color))))
+ (rectangle *bottom-left* *top-right* fill-properties)))
+
+;;; specific things from abstract-projection, individually
+
+(with-projection-context (*gl-c*) (test-translated-rectangles))
+(with-projection-context (*gl-c*) (test-projection-variables))
+(sample-projection *test-raster* *gl-c*)
+(with-projection-context (*gl-c*) (raster #@(|3| -1.0 -1.0 0.0) #@(|3| 1.0 1.0 0.0) *test-raster* ()))
+(context-state)
+
+|#
View
36 tests/tests.asd
@@ -0,0 +1,36 @@
+;;; -*- Mode: LISP; Syntax: Common-lisp; Package: common-lisp-user; Base: 10; Lowercase: Yes -*-
+
+;;; system description file for tests for the `de.setf.graphics` library
+
+(in-package :common-lisp-user)
+
+;; nb. in order to get the contingencies to work,
+;; this system description must load _after_ the graphics library has been built.
+
+(asdf:defsystem :de.setf.graphics.tests
+ :depends-on (:de.setf.graphics)
+ :description "regression tests for de.setf.graphics."
+ :components ((:module :geometry
+ :components ((:file "matrix")))
+ (:module :projection
+ :components ((:file "drawing-mode")
+ (:file "sampler")
+ (:file "life-in-color")
+ (:file "abstract-projection"
+ :depends-on ("drawing-mode" "sampler" "life-in-color"))
+ (:file "ops-per-second")
+ #+de.setf.graphics.clx
+ (:file "clx")
+ #+de.setf.graphics.common-graphics
+ (:file "common-graphics" :depends-on (:de.setf.graphics.common-graphics))
+ #+de.etf.graphics.core-graphics
+ (:file "core-graphics" :weakly-depends-on (:de.setf.graphics.core-graphics))
+ #+de.setf.graphics.opengl
+ (:file "opengl" :weakly-depends-on (:de.setf.graphics.opengl))
+ #+de.setf.graphcis.quickdraw
+ (:file "quickdraw" :weakly-depends-on (:de.setf.graphics.quickdraw))
+ #+de.setf.graphics.svg
+ (:file "svg" :weakly-depends-on (:de.setf.graphics.svg))
+ ))))
+
+:de.setf.graphics

0 comments on commit 5f32fd9

Please sign in to comment.