tests.lisp 3.46 KB
Newer Older
Dave Cooper's avatar
Dave Cooper committed
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
;;
;; Copyright 2002, 2009 Genworks International and Genworks BV 
;;
;; This source file is part of the General-purpose Declarative
;; Language project (GDL).
;;
;; This source file contains free software: you can redistribute it
;; and/or modify it under the terms of the GNU Affero General Public
;; License as published by the Free Software Foundation, either
;; version 3 of the License, or (at your option) any later version.
;; 
;; This source file 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 GNU
;; Affero General Public License for more details.
;; 
;; You should have received a copy of the GNU Affero General Public
;; License along with this source file.  If not, see
;; <http://www.gnu.org/licenses/>.
;; 

(in-package :gdl-user)



(define-object tatu-test (gwl:base-html-sheet)
 
  :computed-slots
  ((list-test '(:a36 nil nil "W3b") :settable)
   
   (nil-test nil :settable)
   
   (keyword-test :a36 :settable)
   
   (string-test "hello" :settable)
   
   (number-test 45 :settable)))


(in-package :gwl-user)


(define-object tatu-children (base-html-sheet)
 
  :computed-slots
  ((length 1 :settable)
   
   (width 2 :settable)
   
   (height 3 :settable)
   
   (aapple (i-dont-know-how 1 2 3))
   
   )
  
  ;; It would be great to be able to see kids 1-3 even though 4 can't appear. Then you can use 
  ;; tatu to help track down the error that feeds kid-4's part type. 
  :objects
  ((kid-1 :type 'my-box
	  :pass-down (:length :width :height))
   
   (kid-2 :type 'my-box
	  :pass-down (:length :width :height))
   
   (kid-3 :type 'my-box
	  :pass-down (:length :width)
	  :height (error "This will cause all of the children not to appear This will cause all of the children not to appear This will cause all of the children not to appear This will cause all of the children not to appear This will cause all of the children not to appear"))
   

   (kid-4 :type (if (> (the kid-3 volume) 10)
		    'my-box
		  'box)		  
	  :pass-down (:length :width :height))
   
   (kid-5 :type 'my-box
	  :sequence (:size 5)
	  :display-controls (if (= (the-child index) 4) 
				   (error "Can't compute display-controls")
			      (list :color :green))
	  :strings-for-display (if (= (the-child index) 3) 
				   (error "Can't compute strings-for-display")
				 (format nil "kid-5 ~a" (the-child index))))
   
   (kid-6 :type 'tatu-children)
   ))



(define-object my-box (box))


(define-object draw-error (base-object)
  
  :objects
  ((box :type 'box 
	:height 20
	:width 10
	:length 10
	:display-controls (list :color :green)
	:center (translate (the center) :left 25))
	
   
   (box-1 :type 'box
	  :height 1 ;;(/ 1 0)
	  :width 10
	  :length 10)))


(define-object measure-distance (base-object)
  
  :objects
  ((left-box :type 'box 
	     :display-controls (list :color :red)
	     :length 10 :width 20 :height 30
	     :center (translate (the center) :left 100))
   
   (left-center-box :type 'box 
		    :display-controls (list :color :orange)
		    :length 10 :width 20 :height 30
		    :center (translate (the center) :left 50))
   
   (right-box :type 'box 
	     :display-controls (list :color :green)
	     :length 10 :width 20 :height 30
	     :center (translate (the center) :right 100))
   
   (right-center-box :type 'box 
	     :display-controls (list :color :blue)
	     :length 10 :width 20 :height 30
	     :center (translate (the center) :right 50))
   
   ))