drilled-block.lisp 3.33 KB
Newer Older
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
;;
;; 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)

Dave Cooper's avatar
Dave Cooper committed
25
#+nil
26
27
28
29
30
(defun dmapcar (function list)
  (dmapc function list)
  (mapcar function list))


Dave Cooper's avatar
Dave Cooper committed
31
#+nil
32
33
(defun dmapc (function list)
  (let ((count -1))
Dave Cooper's avatar
Dave Cooper committed
34
35
    (mapc #'(lambda ()
	      (bt:make-thread function :name (format nil "thread ~a from dmapcar" (incf count))))
36
	  list)))
37
38


39
40
(eval-when (:compile-toplevel :load-toplevel :execute)
  (setq *compile-for-dgdl?* t))
41
42
43
44
45
46
47
48
49

(define-object dgdl-test (base-object)
  
  :input-slots
  ((length 10)
   (width 20)
   (height 30)
   (hole-radius 2 :settable)
   (hole-length 35)
Dave Cooper's avatar
Dave Cooper committed
50
   (quantity 2 :settable))
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
  
  
  :computed-slots 
  ((local-volumes (mapsend (list-elements (the local-drilled)) :volume))
   (remote-volumes (mapsend (list-elements (the remote-drilled)) :volume)))

  
  
  :objects
  (
   (remote-utils :type 'remote-object
		 :remote-type 'remote-utils
		 :sequence (:size (the remote-drilled number-of-elements))
		 :host (the (remote-drilled (the-child index)) host)
		 :port (the (remote-drilled (the-child index)) port))
   
   (local-drilled :type 'drilled-block
		  :sequence (:size (the quantity))
		  :pass-down (hole-length hole-radius))
   
   (remote-drilled :type 'remote-object
		   :sequence (:size (the quantity))
		   :remote-type 'drilled-block
		   :host "localhost"
		   :port (+ (the-child index) 9001)
		   ;;:port (if (oddp (the-child index)) 9001 9002)
		   :pass-down (length width height hole-length hole-radius)))
  
  :functions
  (
   
   (collect-volumes 
Dave Cooper's avatar
Dave Cooper committed
83
84
85
86
    ()
    ;;(&key remote?)

    #+nil
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
    (dmapcar #'(lambda(drilled-block) (the-object drilled-block volume))
	     (list-elements (if remote? (the remote-drilled) (the local-drilled)))))
   
   
   (set-hole-radius! 
    (value)
    (the (set-slot! :hole-radius value)))))



(define-object remote-utils ()
  :functions
  ((clear-remotes 
    ()
    (clrhash gwl::*remote-objects-hash*))
   
   (global-gc
    ()
Dave Cooper's avatar
Dave Cooper committed
105
106
    (glisp:gc-full))))

107
108
109
110
111
112
113
114
115
116



(define-object drilled-block (base-object)
  
  :input-slots 
  (length width height hole-radius hole-length
   
   (quantity 50 :settable))
  
Dave Cooper's avatar
Dave Cooper committed
117
118
119
  :computed-slots ((volume (the result volume))
		   (c-of-g (the result center-of-gravity)))

120
121
  
  :objects
Dave Cooper's avatar
Dave Cooper committed
122
123
  ((result :type 'subtracted-solid
	   :pass-down (brep other-brep))
124
125
126
127
128
129
130
131
   
   (brep :type 'box-solid
	  :display-controls (list :color :green))

   
   (other-brep :type 'cylinder-solid
	       :radius (the hole-radius)
	       :length (the hole-length)
Dave Cooper's avatar
Dave Cooper committed
132
	       :display-controls (list :color :green))))
133
134
135
136


(eval-when (:compile-toplevel :load-toplevel :execute)
  (setq *compile-for-dgdl?* nil))
137
138