← Back to branch summary

~ubuntu-branches/ubuntu/saucy/libctl/saucy

« back to all changes in this revision

Viewing changes to utils/geom.scm

  • Committer: Bazaar Package Importer
  • Author(s): Josselin Mouette
  • Date: 2006-05-01 20:25:01 UTC
  • mfrom: (1.1.2 upstream)
  • Revision ID: james.westby@ubuntu.com-20060501202501-lytbmb3oevyoqzxi
Tags: 3.0.1-1
http://bugs.debian.org/361676
* New upstream release (closes: #361676).
* Major rework of the debian/ directory. Switch to cdbs.
* Migrate Scheme files to a versioned location to allow several
  versions to be installed at once.
* Write a Makefile to put with the example.
* Update copyright, the library is now GPL.
* Use gfortran for the F77 wrappers.
* Standards-version is 3.7.0.

Show diffs side-by-side

added added

removed removed

Lines of Context:
utils/geom.scm
1
1
; libctl: flexible Guile-based control files for scientific software 
2
 
; Copyright (C) 1998, 1999, 2000, 2001, 2002, Steven G. Johnson
 
2
; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2006, Steven G. Johnson
3
3
;
4
4
; This library is free software; you can redistribute it and/or
5
5
; modify it under the terms of the GNU Lesser General Public
21
21
; ****************************************************************
22
22
 
23
23
(if (not (defined? 'material-type))
24
 
    (define-class material-type no-parent)) ; define dummy class
 
24
    (define-class material-type no-parent
 
25
      (define-property data no-default 'SCM))) ; generic user-defined data
 
26
 
 
27
; A default material so that we don't have to specify a material for
 
28
; an object when we just care about its geometry.  If material-type is
 
29
; an "abstract superclass" (no properties of its own), programs could
 
30
; interpret this as equating to default-material (below).  However, we
 
31
; only define this default if (make material-type) works, i.e. if
 
32
; defaults exist for all properties (if any) of material-type.
 
33
(define nothing (if (for-all? (class-properties-all material-type)
 
34
                              property-has-default?)
 
35
                    (make material-type)
 
36
                    no-default))
25
37
 
26
38
(define-class geometric-object no-parent
27
 
  (define-property material no-default 'material-type)
 
39
  (define-property material nothing 'material-type)
28
40
  (define-property center no-default 'vector3))
29
41
 
 
42
(define-class compound-geometric-object geometric-object
 
43
  (define-property component-objects '()
 
44
    (make-list-type 'geometric-object)))
 
45
 
30
46
(define (non-negative? x) (not (negative? x)))
31
47
 
32
48
(define-class cylinder geometric-object
122
138
                     shift-vector min-multiple max-multiple go))
123
139
                  go-list)))
124
140
 
125
 
(define (geometric-objects-lattice-duplicates go-list . usize)
 
141
(define (lattice-duplicates lat go-list . usize)
 
142
  (define (lat->lattice v)
 
143
    (cartesian->lattice (matrix3x3* (object-property-value lat 'basis) v)))
126
144
  (let ((u1 (if (>= (length usize) 1) (list-ref usize 0) 1))
127
145
        (u2 (if (>= (length usize) 2) (list-ref usize 1) 1))
128
146
        (u3 (if (>= (length usize) 3) (list-ref usize 2) 1))
129
 
        (s (object-property-value geometry-lattice 'size)))
130
 
    (let ((b1 (vector3 u1 0 0)) (b2 (vector3 0 u2 0)) (b3 (vector3 0 0 u3))
 
147
        (s (object-property-value lat 'size)))
 
148
    (let ((b1 (lat->lattice (vector3 u1 0 0))) 
 
149
          (b2 (lat->lattice (vector3 0 u2 0)))
 
150
          (b3 (lat->lattice (vector3 0 0 u3)))
131
151
          (n1 (ceiling (/ (vector3-x s) u1)))
132
152
          (n2 (ceiling (/ (vector3-y s) u2)))
133
153
          (n3 (ceiling (/ (vector3-z s) u3))))
139
159
         b3 (- (floor (/ (- n3 1) 2))) (ceiling (/ (- n3 1) 2))
140
160
         go-list))))))
141
161
 
 
162
(define (geometric-objects-lattice-duplicates go-list . usize)
 
163
  (apply lattice-duplicates (cons geometry-lattice
 
164
                                  (cons go-list usize))))
 
165
 
142
166
; ****************************************************************
143
167
 
144
168
(define-input-var dimensions 3 'integer)
145
 
(define-input-var default-material '() 'material-type)
 
169
(define-input-var default-material nothing 'material-type)
 
170
(define-input-var geometry-center (vector3 0) 'vector3)
146
171
(define-input-var geometry-lattice (make lattice) 'lattice)
147
172
(define-input-var geometry '() (make-list-type 'geometric-object))
148
173
(define-input-var ensure-periodicity true 'boolean)
150
175
(define-external-function point-in-object? true false
151
176
  'boolean 'vector3 'geometric-object)
152
177
 
 
178
(define-external-function normal-to-object true false
 
179
  'vector3 'vector3 'geometric-object)
 
180
 
153
181
(define-external-function point-in-periodic-object? true false
154
182
  'boolean 'vector3 'geometric-object)
155
183
 
159
187
(define-external-function display-geometric-object-info false false
160
188
  no-return-value 'integer 'geometric-object)
161
189
 
 
190
(define-external-function range-overlap-with-object true false
 
191
  'number 'vector3 'vector3 'geometric-object 'number 'integer)
 
192
 
162
193
(define-external-function square-basis false false
163
194
  'matrix3x3 'matrix3x3 'vector3)
164
195
 
169
200
(define-param resolution 10)   ; the resolution (may be a vector3)
170
201
(define-param grid-size false) ; force grid size, if set
171
202
 
 
203
(define (get-resolution)
 
204
  (if (vector3? resolution)
 
205
      resolution
 
206
      (vector3 resolution resolution resolution)))
172
207
(define (get-grid-size)
173
208
  (if grid-size
174
209
      grid-size
175
 
      (let ((res (if (vector3? resolution)
176
 
                     resolution
177
 
                     (vector3 resolution resolution resolution))))
 
210
      (let ((res (get-resolution)))
178
211
        (vector-map
179
212
         (lambda (x) (inexact->exact (max (ceiling x) 1)))
180
213
         (vector-map * res (object-property-value geometry-lattice 'size))))))