;================================================== ; MzPlasm ; Author: ; Simone Portuesi ; Revision: ; Giorgio Scorzelli ; Stefano Francesi ; Franco Milicchio ; Alberto Paoluzzi ; DATE: January 2001 ; LAST REVISION : July 30, 2004 ;================================================== ;--------------------------------------------------------------------- ; A function to control if all "alist" items satisfy pred ;--------------------------------------------------------------------- (define (every pred alist) (if (list? alist) (do ((res #t) (todo alist (cdr todo))) ((or (not res) (null? todo)) res) (set! res (pred (car todo)))) #f)) ;--------------------------------------------------------------------- ; Define the top level environment ;--------------------------------------------------------------------- (define *f_env* (make-env make-val-def (make-hash-assoc))) (define *env* *f_env*) ;--------------------------------------------------------------------- ; Define utility functions ;--------------------------------------------------------------------- (define (welcome port) (begin (newline port) (display "**************************************************" port) (newline port) (display "* Welcome in *" port) (newline port) (display "* PLaSM *" port) (newline port) (display "* *" port) (newline port) (display "* [Programming LAnguage for Solid Modeling] *" port) (newline port) (display "* *" port) (newline port) (display "* Version: 4.2.0 *" port) (newline port) (display "* Date: 24 Nov 2004 *" port) (newline port) (display "* *" port) (newline port) (display "**************************************************" port) (newline port) (display "plasm") )) (define (plasmhelp port) (begin (newline port) (display "************************************************************" port) (newline port) (display "* PLASM Help *" port) (newline port) (display "* *" port) (newline port) (display "* (LOAD \"filename.psm\") *" port) (newline port) (display "* ... to load in memory a PLaSM file. *" port) (newline port) (display "* \"LOADLIB: 'libname'\" *" port) (newline port) (display "* ... to load in memory a PLaSM library of functions. *" port) (newline port) (display "* (PLASM \"expression\") *" port) (newline port) (display "* ... to evaluate a PLaSM expression. *" port) (newline port) (display "* \"EXPORT_VRML: complex\" *" port) (newline port) (display "* ... to export a polyhedral complex in VRML2 format. *" port) (newline port) (display "* \"EXPORT: complex : 'filename'\" *" port) (newline port) (display "* ... to export a polyhedral complex to VRML2 filename. *" port) (newline port) (display "* \"DUMP: complex\" *" port) (newline port) (display "* ... to dump representation of a polyhedral complex. *" port) (newline port) (display "* (EXIT) *" port) (newline port) (display "* ... to close PLaSM interpreter. *" port) (newline port) (display "* *" port) (newline port) (display "************************************************************" port) (newline port) )) ;-------------------------------------------------------------------- ;; Main function to export VRML ;; Giorgio Scorzelli. I create a filter to "--server" mode! ;; No user should save its vrml files where he wants! ;-------------------------------------------------------------------- (define (filter-name filename) (if (not remote-plasm-web-mode) filename (create-tmp-base-name ".wrl"))) (define (export-vrml-pol-complex-with-info pol filename typeoutput) (let ((new-file-name (normalize-path (filter-name filename)))) (begin (newline) (display "--------------------------------------------") (newline) (display "Exporting object to VRML (ver 2) file format") (newline) (display "Filename = ") (display new-file-name) (newline) (display "Dimensions: Point = ") (display (send pol get-dpol-dim)) (display " Spatial = " ) (display (send pol get-npol-dim)) (newline) (send pol export-vrml-pol-complex (if remote-plasm-web-mode (build-path (current-directory) "tmp" new-file-name) filename) typeoutput) (display "--------------------------------------------") (newline) (display "End of exporting phase") (newline) (newline) (if remote-plasm-web-mode (begin (display (url-to-client (string-append remote-plasm-mzplasm-www-url "tmp/" new-file-name)) remote-plasm-direct-out) (flush-output remote-plasm-direct-out))) (if remote-plasm-socket-mode (begin (display (url-to-client filename) remote-plasm-direct-out) (flush-output remote-plasm-direct-out))) ))) ;; Giorgio Scorzelli ;; Function to export SVG (define (export-svg-pol-complex-with-info pol filename width) (let ((new-file-name (normalize-path (filter-name filename)))) (begin (newline) (display "--------------------------------------------") (newline) (display "Exporting object to SVG file format ") (newline) (display "Filename = ") (display new-file-name) (newline) (display "Width = ")(display width) (display "cm Height = ")(display width)(display "cm")(newline) (send pol export-svg-pol-complex width (if remote-plasm-web-mode (build-path (current-directory) "tmp" new-file-name) filename)) (display "--------------------------------------------") (newline) (display "End of exporting phase") (newline) (newline) (if remote-plasm-web-mode (begin (display (url-to-client (string-append remote-plasm-mzplasm-www-url "tmp/" new-file-name)) remote-plasm-direct-out) (flush-output remote-plasm-direct-out))) (if remote-plasm-socket-mode (begin (display (url-to-client filename) remote-plasm-direct-out) (flush-output remote-plasm-direct-out))) ))) ;; new Flash export (define (export-flash-pol-complex-with-info pol filename width) (let ((new-file-name (normalize-path (filter-name filename)))) (begin (newline) (display "--------------------------------------------") (newline) (display "Exporting object to FLASH file format ") (newline) (display "Filename = ") (display new-file-name) (newline) (display "Width = ")(display width)(newline) (display " pixel ") (newline) (send pol export-flash-pol-complex width (if remote-plasm-web-mode (build-path (current-directory) "tmp" new-file-name) filename)) (display "--------------------------------------------") (newline) (display "End of exporting phase") (newline) (newline) (if remote-plasm-web-mode (begin (display (url-to-client (string-append remote-plasm-mzplasm-www-url "tmp/" new-file-name)) remote-plasm-direct-out) (flush-output remote-plasm-direct-out))) (if remote-plasm-socket-mode (begin (display (url-to-client filename) remote-plasm-direct-out) (flush-output remote-plasm-direct-out))) ))) ;; new Flash Animation export (define (export-flash-animation-with-info pollist filename width framerate) (let ((new-file-name (normalize-path (filter-name filename)))) (begin (newline) (display "--------------------------------------------") (newline) (display "Exporting animation to FLASH file format ") (newline) (display "Filename = ") (display new-file-name) (newline) (display "Width = ")(display width) (display " pixel ") (newline) (display "Frame rate = ") (display framerate)(newline) (export-flash-animation pollist width framerate (if remote-plasm-web-mode (build-path (current-directory) "tmp" new-file-name) filename)) (display "--------------------------------------------") (newline) (display "End of exporting phase") (newline) (newline) (if remote-plasm-web-mode (begin (display (url-to-client (string-append remote-plasm-mzplasm-www-url "tmp/" new-file-name)) remote-plasm-direct-out) (flush-output remote-plasm-direct-out))) (if remote-plasm-socket-mode (begin (display (url-to-client filename) remote-plasm-direct-out) (flush-output remote-plasm-direct-out))) ))) (define (plasm-to-vrml filename) (begin (time ; (load filename) (eval-plasm (read-string 20000000 (open-input-file filename))) (eval-plasm (string-append "export_vrml_with_name:out:'" (string-append filename ".wrl") "'"))) )) (define (plasm-to-xml filename) (begin (time ; (load filename) (eval-plasm (read-string 20000000 (open-input-file filename))) (eval-plasm (string-append "save:out:'" (string-append filename ".xml") "'"))) )) (define (loadlib lib_name) ; (load (build-path *PLASMLIBSDIR* (string-append lib_name ".psm"))) (eval-plasm (read-string 20000000 (open-input-file (build-path *PLASMLIBSDIR* (string-append lib_name ".psm")) ))) ) ;-------------------------------------------------------------------- ; Plasm generic (not geometric) function ;--------------------------------------------------------------------- (for-each ; *** For each:: function to apply *** (lambda (elem) (if (pair? (car elem)) (for-each (lambda (name) (*f_env* 'def name (eval `(lambda () ,(cadr elem))))) (car elem)) (*f_env* 'def (car elem) (eval `(lambda () ,(cadr elem)))))) ; *** For each::list *** `( ;(scheme_error ,(lambda (arg) (error 'scheme "ddd" arg))) (k ,(lambda (x) (lambda (y) x))) (id ,(lambda (x) x)) (nlist ,(lambda (n) (if (number? n) (let ((vars (do ((cnt 0 (+ cnt 1)) (vars '() (cons (string->symbol (string-append "x" (number->string cnt))) vars))) ((= cnt n) vars)))) (do ((todo vars (cdr todo)) (lambdas (cons 'list (reverse vars)) `(lambda (,(car todo)) ,lambdas))) ((null? todo) (eval lambdas))) ) (plasm-exception `( "NLIST" "IsNum" ,n))))) ;applies a list of function to a single arg (cons ,(lambda (fun_list) (if (every procedure? fun_list) (lambda (arg) (map (lambda (fun) (fun arg)) fun_list)) (plasm-exception `( "CONS" "IsSeqOf:IsFun" ,fun_list))))) ;applies a list of function to a list of args (pcons ,(lambda (fun_list) (if (every procedure? fun_list) (lambda (arg_list) (if (and (list? arg_list) (= (length arg_list) (length fun_list))) (do ((arg_list arg_list (cdr arg_list)) (fun_list fun_list (cdr fun_list)) (res '())) ((null? arg_list) res) (set! res (append res (list ((car fun_list) (car arg_list)))))) (plasm-exception `( "PCONS:IsSeqOf:IsFun" "IsSeq (??)" ,arg_list)))) (plasm-exception `( "PCONS" "IsSeqOf:IsFun" ,fun_list))))) ;applies a function to a list of args (aa ,(lambda (fun) (if (procedure? fun) (lambda (arg_list) (if (list? arg_list) (map (lambda (arg) (fun arg)) arg_list) (plasm-exception `( "AA:IsFun" "IsSeq" ,arg_list)))) (plasm-exception `( "AA" "IsFun" ,fun))))) ;applies fun to a list of values returned by the application of a CONS of a list of function on a single arg (lift ,(lambda (fun) (if (procedure? fun) (lambda (fun_list) (if (every procedure? fun_list) (lambda (arg) (fun (map (lambda (fun) (fun arg)) fun_list))) (plasm-exception `( "LIFT:IsFun" "IsSeqOf:IsFun" ,fun_list)))) (plasm-exception `( "LIFT" "IsFun" ,fun))))) ;acts like lift, but if list is not a procedure non-empty list, it returns the application of fun to list (raise ,(lambda (fun) (if (procedure? fun) (lambda (list) (cond ((and (pair? list) (every procedure? list)) (lambda (arg) (fun (map (lambda (fun) (fun arg)) list)))) ;((list? list) ; (fun list)) ; sperimentale ; def plasm e fl: "if::arg" ; ((procedure? list) (lambda (arg) (fun (list arg)))) (#t (fun list)))) ;(#t (plasm-exception `( "RAISE:IsFun" "IsSeqOf:IsFun OR IsSeq"))))) (plasm-exception `( "RAISE" "IsFun" ,fun))))) ;currify a function (c ,(lambda (fun) (if (procedure? fun) (lambda (x) (lambda (y) (fun (list x y)))) (plasm-exception `( "C" "IsFun" ,fun))))) ;applies a list of functions to a single arg, composing them (comp ,(lambda (fun_list) (if (every procedure? fun_list) (lambda (arg) (do ((res arg) (todo (reverse fun_list) (cdr todo))) ((null? todo) res) (set! res ((car todo) res)))) (plasm-exception `( "COMP" "IsSeqOf:IsFun" ,fun_list))))) (~ ,(lambda (fun_list) (if (every procedure? fun_list) (lambda (arg) (do ((res arg) (todo (reverse fun_list) (cdr todo))) ((null? todo) res) (set! res ((car todo) res)))) (plasm-exception `( "COMP" "IsSeqOf:IsFun" ,fun_list))))) (if ,(lambda (fun_list) (if (and (pair? fun_list) (eq? 3 (length fun_list)) (every procedure? fun_list) ) (lambda (arg) (let ((cond_res ((car fun_list) arg))) (if (and cond_res (not (eq? cond_res '()))) ((cadr fun_list) arg) ((caddr fun_list) arg)))) (plasm-exception `( "IF" "[|IsFun,IsFun,IsFun|]" ,fun_list))))) (insl ,(lambda (fun) (if (procedure? fun) (lambda (arg_list) (if (pair? arg_list) (do ((res (car arg_list) (fun (list res (car todo)))) (todo (cdr arg_list) (cdr todo))) ((null? todo) res)) (plasm-exception `( "INSL:IsFun" "AND~[IsSeq,NOT~ISNULL]" ,arg_list)))) (plasm-exception `( "INSL" "IsFun" ,fun))))) (insr ,(lambda (fun) (if (procedure? fun) (lambda (arg_list) (if (pair? arg_list) (do ((res (list-ref arg_list (1- (length arg_list))) (fun (list (car todo) res))) (todo (cdr (reverse arg_list)) (cdr todo))) ((null? todo) res)) (plasm-exception `( "INSR:IsFun" "AND~[IsSeq,NOT~ISNULL]" ,arg_list)))) (plasm-exception `( "INSR" "IsFun" ,fun))))) ; vedere plasm-orig, sospetto incoerenza tra plasm e FL (tree ,(lambda (fun) (if (procedure? fun) (lambda (arg_list) (if (pair? arg_list) (let tree ((fun fun) (arg_list arg_list)) (if (null? (cdr arg_list)) (car arg_list) (let* ((n (length arg_list)) ;(k (ceiling (/ n 2))) (k (quotient n 2)) ;(k (+ (quotient n 2) (remainder n 2))) ) (fun (list (tree fun (reverse! (list-tail (reverse arg_list) (- n k)))) (tree fun (list-tail arg_list k))))))) (plasm-exception `( "TREE:IsFun" "AND~[IsSeq,NOT~ISNULL]" ,arg_list)))) (plasm-exception `( "TREE" "IsFun" ,fun))))) (merge ,(lambda (fun) (if (procedure? fun) (lambda (arg_list) (if (and (pair? arg_list) (every list? arg_list)) (let merge ((fun fun) (arg_list arg_list)) (cond ((null? (car arg_list)) (cadr arg_list)) ((null? (cadr arg_list)) (car arg_list)) ((fun (list (caar arg_list) (caadr arg_list))) (cons (caar arg_list) (merge fun (list (cdar arg_list) (cadr arg_list))))) (#t (cons (caadr arg_list) (merge fun (list (car arg_list) (cdadr arg_list))))))) (plasm-exception `( "MERGE:IsFun" "AND~[IsSeq,NOT~ISNULL]" ,arg_list)))) (plasm-exception `( "MERGE" "IsFun" ,fun))))) (case ,(lambda (pred-funs) (if (and (list? pred-funs) (every (lambda (elem) (and (list? elem) (eq? 2 (length elem)) (every procedure? elem))) pred-funs)) (lambda (arg) (do ( ;(fres #f (if pres ((cadar todo) arg) #f)) (pres ((caar pred-funs) arg) ((caar todo) arg)) (todo pred-funs )) ((or pres (null? todo)) (if (null? todo) (plasm-exception `( "CASE:(IsSeqOf:(AND~[IsPair,IsSeqOf:IsFun]):TT)" "Non Exaustive Predicates" )) ((cadar todo) arg))) (set! todo (cdr todo)))) (plasm-exception `( "CASE" "IsSeQOf:(AND~[IsPair,IsSeqOf:IsFun]" ,pred-funs))))) (apply ,(lambda (fun_and_arg) (if (and (pair? fun_and_arg) (eq? 2 (length fun_and_arg)) (procedure? (car fun_and_arg))) ((car fun_and_arg) (cadr fun_and_arg)) (plasm-exception `( "APPLY" "[|IsFun,IsVal|]" ,fun_and_arg))))) (isfun procedure?) (isseq list?) (isseqof ,(lambda (pred) (lambda (seq) (every pred seq)))) (isnull null?) (ff ,(lambda (x) #f)) (tt ,(lambda (x) #t)) (ispair ,(lambda (x) (and (pair? x) (eq? 2 (length x))))) ; (isstring (lambda (str) (every char? str))) (isstring string?) (isbool boolean?) (isnum number?) (isint integer?) (isreal real?) (isnumpos ,(lambda (num) (and (number? num) (positive? num)))) (isnumneg ,(lambda (num) (and (number? num) (negative? num)))) (isintpos ,(lambda (num) (and (integer? num) (positive? num)))) (isintneg ,(lambda (num) (and (integer? num) (negative? num)))) (isrealpos ,(lambda (num) (and (real? num) (positive? num)))) (isrealneg ,(lambda (num) (and (real? num) (negative? num)))) (intmax ,(lambda (num) (if (number? num) (inexact->exact (ceiling num)) (plasm-exception `( "INTMAX" "ISNUM" ,num))))) (intmin ,(lambda (num) (if (number? num) (inexact->exact (floor num)) (plasm-exception `( "INTMIN" "ISNUM" ,num))))) (abs ,(lambda (num) (if (number? num) (abs num) (plasm-exception `( "ABS" "ISNUM" ,num))))) ; Stefano Francesi ; extended use to boolean difference ;************************************************ ; Alessandro La Rosa ; added support to multiple lists and to matrices ; for all arithmetic operators ;************************************************ (sub ,(lambda (args) (cond ((and (pair? args) (every number? args)) (apply - args)) ((number? args) (- args)) ((and *USE_GEOMETRY* (every pol-complex? args)) ((get-env *env* 'differencepr) args)) ((and (pair? args) (every list? args) (> (length args) 1)) (let loop ([hh (car args)][tt (cdr args)]) (if (and (pair? tt) (>= (length tt) 2)) (loop (matrix-sub hh (car tt)) (cdr tt)) (matrix-sub hh (car tt)))) ) ((and (pair? args) (every list? args)) (car args)) ;aggiungere liste (#t (plasm-exception `( "SUB" "IsNum OR IsSeqOf~OR~[IsNum,IsSeq,IsPol]" ,args)))))) (- ((get-env *env* 'raise) (get-env *env* 'sub))) (add ,(lambda (args) ; i casi sono fatti a mano si dovrebbe definire l'overload (cond ((every number? args) (apply + args)) ;((and *USE_GEOMETRY* (every is-pol-complex? args)) ;(get-env *env* ' ((number? args) (+ args)) ((and *USE_GEOMETRY* (every pol-complex? args)) ((get-env *env* 'unionpr) args)) ((and (pair? args) (every list? args) (> (length args) 1)) (let loop ([hh (car args)][tt (cdr args)]) (if (and (pair? tt) (>= (length tt) 2)) (loop (matrix-add hh (car tt)) (cdr tt)) (matrix-add hh (car tt))))) ((and (pair? args) (every list? args)) (car args)) ;aggiungere liste e polc (#t (plasm-exception `( "ADD" "IsNum OR IsSeqOf~OR~[IsNum,IsSeq,IsPol]" ,args)))))) (+ ((get-env *env* 'raise) (get-env *env* 'add))) ; Stefano Francesi ; extended use to boolean progressive difference (div ,(lambda (args) (cond ((and (pair? args) (every number? args) (every (lambda (x) (not (eq? x 0))) (cdr args))) (apply / args)) ((and *USE_GEOMETRY* (every pol-complex? args)) ((get-env *env* 'pdifference) args)) ((and (pair? args) (every list? args) (> (length args) 1)) (if (every square-mat args) (if (every (notceq 0) (map det (cdr args))) (let loop ([hh (car args)][tt (cdr args)]) (if (and (pair? tt) (>= (length tt) 2)) (loop (matrix-multiply hh (matrix-invert (car tt))) (cdr tt)) (matrix-multiply hh (matrix-invert (car tt))))) (plasm-exception `( "DIV" "Division is possible only with non-singular matrices", args))) (let loop2 ([hh (car args)][tt (cdr args)]) (if (and (pair? tt) (>= (length tt) 2)) (let ((step1 (matrix-multiply (trans (car tt)) (car tt)))) (if (not (= (det step1) 0)) (let ((step2 (matrix-multiply (matrix-invert step1) (trans (car tt))))) (loop2 (matrix-multiply hh step2) (cdr tt))) (plasm-exception `( "DIV" "Moore-Pensore pseudo-inverse not generable:", (car tt))))) (let ((step1 (matrix-multiply (trans (car tt)) (car tt)))) (if (not (= (det step1) 0)) (let ((step2 (matrix-multiply (matrix-invert step1) (trans (car tt))))) (matrix-multiply hh step2)) (plasm-exception `( "DIV" "Moore-Pensore pseudo-inverse not generable:", (car tt))))))))) ((and (pair? args) (every list? args)) (car args)) (#t (plasm-exception `( "DIV" "IsNum OR IsSeqOf~IsNum" ,args)))))) (/ ((get-env *env* 'raise) (get-env *env* 'div))) (mul ,(lambda (args) (cond ((and (pair? args) (every number? args)) (apply * args)) ((and (pair? args) (every pol-complex? args) (> (length args) 1)) (let loop ([hh (car args)][tt (cdr args)]) (if (and (pair? tt) (>= (length tt) 2)) (loop (send hh power (car tt)) (cdr tt)) (send hh power (car tt))))) ((and (pair? args) (every pol-complex? args) (= (length args) 1)) args) ;--------------------------------------------------- ; Giorgio Scorzelli ; probabilmente vanno aggiunti dei controlli in piu! ;--------------------------------------------------- ((and (pair? args) (every list? args) (> (length args) 1)) (let loop ([hh (car args)][tt (cdr args)]) (if (and (pair? tt) (>= (length tt) 2)) (loop (matrix-multiply hh (car tt)) (cdr tt)) (matrix-multiply hh (car tt))))) ((and (pair? args) (every list? args)) (car args)) ; Giorgio Scorzelli ; (t (plasm-exception `( "MUL" "IsNum OR IsSeqOf~IsNum" ,args)))))) (#t (plasm-exception `( "MUL" "IsNum OR IsSeqOf~IsNum OR IsSeqOf~IsSeqOf~IsNum" ,args)))))) (* ( (get-env *env* 'raise) (get-env *env* 'mul))) (less (lambda (args) (if (or (number? args) (and (pair? args) (every number? args))) (apply < args) (#t (plasm-exception `( "LESS" "IsNum OR IsSeqOf~IsNum" ,args)))))) (lt ,(lambda (a) (cond ((number? a) (lambda (b) (if (number? b) (> a b) (plasm-exception `( "LT:IsNum" "IsNum" ,b))))) ((string? a) (lambda (b) (if (string? b) (string-ci>? a b)))) (#t (plasm-exception `( "LT" "IsNum" ,a)))))) (greater (lambda (args) (if (or (number? args) (and (pair? args) (every number? args))) (apply > args) (#t (plasm-exception `( "GREATER" "IsNum OR IsSeqOf~IsNum" args)))))) (gt ,(lambda (a) (cond ((number? a) (lambda (b) (if (number? b) (< a b) (plasm-exception `( "GT:IsNum" "IsNum" ,b))))) ((string? a) (lambda (b) (if (string? b) (string-ci= a b) (plasm-exception `( "LE:IsNum" "IsNum" ,b))))) ((string? a) (lambda (b) (if (string? b) (string-ci>=? a b)))) (#t (plasm-exception `( "LE" "IsNum" ,a)))))) (greatereq (lambda (args) (if (or (number? args) (and (pair? args) (every number? args))) (apply >= args) (#t (plasm-exception `( "GRATEREQ" "IsNum OR IsSeqOf~IsNum" args)))))) (ge ,(lambda (a) (cond ((number? a) (lambda (b) (if (number? b) (<= a b) (plasm-exception `( "GE:IsNum" "IsNum" ,b))))) ((string? a) (lambda (b) (if (string? b) (string-ci<=? a b)))) (#t (plasm-exception `( "GE" "IsNum" ,a)))))) (eq ,(lambda (args) (if (pair? args) (every (lambda (elem) (equal? elem (car args))) args) #t))) (neq ,(lambda (args) (not (if (pair? args) (every (lambda (elem) (equal? elem (car args))) args) #t)))) ; problema in Plasm ritornava nil (true #t) (false #f) (and ,(lambda (seq) (if (list? seq) (if (every (lambda (elem) (and elem (not (eq? elem '())))) seq) #t #f) (plasm-exception `( "AND" "IsSeq" ,seq))))) (or ,(lambda (seq) (if (list? seq) (if (every (lambda (elem) (or (not elem) (eq? elem '()))) seq) #f #t) (plasm-exception `( "OR" "IsSeq" ,seq))))) (not ,(lambda (arg) (if (or (not arg) (eq? arg '())) #t #f))) ;rivedere liste per problema condizioni ed eccezioni (len ,(lambda (seq) (if (list? seq) (length seq) (plasm-exception `( "LEN" "IsSeq" ,seq))))) (list list) (first ,(lambda (seq) (if (list? seq) (aref seq 0) (plasm-exception `( "FIRST" "AND~[IsSeq,NOT~NULL]" ,seq))))) (last ,(lambda (seq) (if (pair? seq) (aref seq (1- (length seq))) (plasm-exception `( "LAST" "AND~[IsSeq,NOT~NULL]" ,seq))))) (tail ,(lambda (seq) (if (pair? seq) (cdr seq) (plasm-exception `( "TAIL" "AND~[IsSeq,NOT~NULL]" ,seq))))) (tailr ,(lambda (seq) (if (pair? seq) (reverse (cdr (reverse seq))) (plasm-exception `( "TAILR" "AND~[IsSeq,NOT~NULL]" ,seq))))) (reverse ,(lambda (seq) (if (list? seq) (reverse seq) (plasm-exception `( "REVERSE" "IsSeq" ,seq))))) (sel ,(lambda (i) (if (integer? i) (lambda (seq) (cond ((and (positive? i) (list? seq) (<= i (length seq))) (list-ref seq (1- i))) ((and (negative? i) (list? seq) (<= (- i) (length seq))) (list-ref seq (+ (length seq) i))) (#t (plasm-exception `( "SEL:IsInt" "IsSeq (?)" ,seq))))) (plasm-exception `( "SEL" "IsInt" ,i))))) (cat ,(lambda (seq) (if (every list? seq) (do ((res '() (append res (car todo) )) (todo seq (cdr todo))) ((null? todo) res)) (plasm-exception `( "CAT" "IsSeqOf:IsSeq" ,seq))))) (al ,(lambda (arg_seq) (if (and (list? arg_seq) (eq? 2 (length arg_seq)) (list? (list-ref arg_seq 1))) (cons (list-ref arg_seq 0) (list-ref arg_seq 1)) (plasm-exception `( "AL" "[|TT,IsSeq|]" ,arg_seq))))) (ar ,(lambda (arg_seq) (if (and (list? arg_seq) (eq? 2 (length arg_seq)) (list? (list-ref arg_seq 0))) (append (list-ref arg_seq 0) (list (list-ref arg_seq 1))) (plasm-exception `( "AR" "[|TT,IsSeq|]" ,arg_seq))))) (distl ,(lambda (arg_seq) (if (and (list? arg_seq) (eq? 2 (length arg_seq)) (list? (list-ref arg_seq 1))) (map (lambda (elem) (list (list-ref arg_seq 0) elem)) (list-ref arg_seq 1)) (plasm-exception `( "DISTL" "[|TT,IsSeq|]" ,arg_seq))))) (distr ,(lambda (arg_seq) (if (and (list? arg_seq) (eq? 2 (length arg_seq)) (list? (list-ref arg_seq 0))) (map (lambda (elem) (list elem (list-ref arg_seq 1))) (list-ref arg_seq 0)) (plasm-exception `( "DISTR" "[|TT,IsSeq|]" ,arg_seq))))) (trans ,(lambda (seq) (if (and (list? seq) (every list? seq) (or (null? (cdr seq)) (apply = (map length seq)))) (do ((res '() (append res (list (map car todo)))) (todo seq (map cdr todo))) ((every null? todo) res)) (plasm-exception `( "TRANS" ,seq ))))) (intsto ,(lambda (i) (if (integer? i) (if (>= i 0) (do ((res '() (cons cnt res)) (cnt i (1- cnt))) ((eq? cnt 0) res)) (do ((res '() (cons cnt res)) (cnt i (1+ cnt))) ((eq? cnt 0) res))) (plasm-exception `( "INTSTO" "IsInt" ,i))))) ; Stefano Francesi: Problema !! In PLaSM la fromto restituiva NIL se il secondo operando ; era <= al primo ... Adattato il codice alla vecchia versione e trasferita ; la nuova nella funzione RANGE (fromto ,(lambda (arg_seq) (if (and (list? arg_seq) (eq? 2 (length arg_seq)) (integer? (list-ref arg_seq 0)) (integer? (list-ref arg_seq 1))) (let ((op 1-) (from (list-ref arg_seq 0)) (to (list-ref arg_seq 1))) (if (> from to) '() (do ((res '() (cons cnt res)) (cnt to (op cnt))) ((eq? cnt (op from)) res)))) (plasm-exception `( "FROMTO" "[|IsInt,IsInt|]" ,arg_seq))))) (range ,(lambda (arg_seq) (if (and (list? arg_seq) (eq? 2 (length arg_seq)) (integer? (list-ref arg_seq 0)) (integer? (list-ref arg_seq 1))) (let ((op (if (< (list-ref arg_seq 0) (list-ref arg_seq 1)) 1- 1+)) (from (list-ref arg_seq 0)) (to (list-ref arg_seq 1))) (do ((res '() (cons cnt res)) (cnt to (op cnt))) ((eq? cnt (op from)) res))) (plasm-exception `( "RANGE" "[|IsInt,IsInt|]" ,arg_seq))))) (.. (get-env *env* 'fromto)) (\# ,(lambda (i) (if (and (integer? i) (>= i 0)) (lambda (expr) (do ((res '() (cons expr res)) (cnt 0 (1+ cnt))) ((eq? cnt i) res))) (plasm-exception `( "#" "IsInt" ,i))))) (\#\# ,(lambda (i) (if (and (integer? i) (>= i 0)) (lambda (seq) (if (list? seq) (do ((res '() (append seq res)) (cnt 0 (1+ cnt))) ((eq? cnt i) res)) (plasm-exception `( "##:IsInt" "IsSeq" ,seq)))) (plasm-exception `( "##" "IsInt" ,i))))) (sym ,(lambda (str) (if (string? str) (string->symbol str) (plasm-exception `( "SYM" "IsString" ,str))))) ; warning, in mzscheme 102 has changed (time ,(lambda (fun) (lambda (arg) (if (procedure? fun) (call-with-values (lambda () (time (fun arg))) (lambda arg arg )) (plasm-exception `( "TIME" "IsFun")))))) (signal ,(lambda (expr) (plasm-exception expr))) (catch ,(lambda (two_funs) (if (and (pair? two_funs) (eq? 2 (length two_funs)) (procedure? (car two_funs)) (procedure? (cadr two_funs))) (lambda (x) (let ((res (call-with-current-continuation (lambda (exception_h) (fluid-let ((plasm-exception (lambda (arg) (exception_h (cons 'Plasm_exception arg))))) (cons 'Plasm_value ((car two_funs) x))))))) (case (car res) ('Plasm_exception ((cadr two_funs) (list x (cdr res)))) (else (cdr res))))) (plasm-exception `("CATCH" "[|IsFun,IsFun|]" ,two_funs))))) ; Math Functions (pi 3.14159265358979) (powerelev ,(lambda (two_nums) (if (and (pair? two_nums) (eq? 2 (length two_nums)) (number? (car two_nums)) (number? (cadr two_nums))) ; Giorgio Scorzelli ; E' strano (forse bug di MzScheme ma (expt 0.0 0) da #inf) ; con tutte le altre combinazioni (interi/double) funziona ; (apply expt two_nums) (apply expt (list (+ 0.0 (car two_nums)) (+ 0.0 (cadr two_nums)) ) ) (plasm-exception `( "**" "[|IsNum,IsNum|]" ,two_nums))))) ;(** ((get-env *env* RAISE) (get-env *env* POWERELEV))) (** ( (get-env *env* 'raise) (get-env *env* 'powerelev))) (exp ,(lambda (x) (if (number? x) (exp x) (plasm-exception `( "EXP" "IsNum" ,x))))) (ln ,(lambda (x) (if (number? x) (log x) (plasm-exception `( "LOG" "IsNum" ,x))))) (sign ,(lambda (x) (if (number? x) (cond ((positive? x) 1) ((negative? x) -1) (#t 0)) (plasm-exception `( "SIGN" "IsNum" ,x))))) (sqrt ,(lambda (x) (if (number? x) (sqrt x) (plasm-exception `( "SQRT" "IsNum" ,x))))) (cos ,(lambda (x) (if (number? x) (cos x) (plasm-exception `( "COS" "IsNum" ,x))))) (acos ,(lambda (x) (if (number? x) (acos x) (plasm-exception `( "ACOS" "IsNum" ,x))))) (sin ,(lambda (x) (if (number? x) (sin x) (plasm-exception `( "SIN" "IsNum" ,x))))) (asin ,(lambda (x) (if (number? x) (asin x) (plasm-exception `( "ASIN" "IsNum" ,x))))) (tan ,(lambda (x) (if (number? x) (tan x) (plasm-exception `( "TAN" "IsNum" ,x))))) ;controllare, complessa (atan ,(lambda (x) (if (number? x) (atan x) (plasm-exception `( "SQRT" "IsNum" ,x))))) ; Giorgio Marzano (ceil ,(lambda (x) (if (number? x) (ceiling x) (plasm-exception `( "CEIL" "IsNum" ,x))))) ; Giorgio Marzano (floor ,(lambda (x) (if (number? x) (floor x) (plasm-exception `( "FLOOR" "IsNum" ,x))))) ; Giorgio Marzano (sinh ,(lambda (x) (if (number? x) (* 0.5 (- (exp x)(exp (- x)))) (plasm-exception `( "SINH" "IsNum" ,x))))) ; Giorgio Marzano (cosh ,(lambda (x) (if (number? x) (* 0.5 (+ (exp x)(exp (- x)))) (plasm-exception `( "COSH" "IsNum" ,x))))) ; Giorgio Marzano (tanh ,(lambda (x) (if (number? x) (/ (- (exp x)(exp (- x))) (+ (exp x)(exp (- x)))) (plasm-exception `( "TANH" "IsNum" ,x))))) ; INVersa di una matrice ; By Giorgio Scorzelli (inv ,(lambda (x) (matrix-invert x))) (addition ,(lambda (args) (cond ((and (pair? args) (every number? args)) (apply + args)) ((and (pair? args) (every list? args)) (matrix-add (car args) (cadr args))) (#t (plasm-exception `( "ADDITION" "IsNum OR IsSeqOf~IsNum OR IsSeqOf~IsSeqOf~IsNum" ,args)))))) ; Determinante di una matrice ; by Giogio Scorzelli (determinant ,(lambda (x) (det x))) ; Intersezione di estrusioni ; Stefano Francesi ;(&& ,(lambda (coord-list) ; (let ((coords (if (list? coord-list) coord-list (list coord-list)))) ; (lambda (pol-pair) ; (if (and (pair? pol-pair) ; (every pol-complex? pol-pair)) ; (send (first pol-pair) int-of-extr (second pol-pair) coords) ; (plasm-exception `( "&&:(IsSeqOf:Coords):(IsSeqOf:IsPol)" ,pol-pair))))))) ;---------------------------------------------------------------------------------------------; ; Simone Portuesi, overloaded for animated pol complex ((with $) ,(lambda (x) (if (and (list? x) (eq? 2 (length x))) (let ((obj (car x)) (props (cadr x))) (cond ((and (list? props) (eq? 2 (length props)) (string? (car props))) (begin (cond ((pol-complex? obj) (let ((newobj (send obj add-prop-pol-complex props))) ; insert here a for-each to retrieve previous props (set! obj newobj) (add-gp obj (car props) (cadr props)))) ((anim-pol-complex? obj) (let ((newobj (send (anim-pol-complex-pol obj) add-prop-pol-complex props))) (add-gp newobj (car props) (cadr props)) (set! obj (make-anim-pol-complex newobj (anim-pol-complex-id obj) (anim-pol-complex-tStart obj) (anim-pol-complex-tEnd obj)))))) obj )) ((and (list? props) (every (lambda (x) (and (list? x) (eq? 2 (length x)) (string? (car x)))) props)) (begin (map (lambda (prop) (begin (cond ((pol-complex? obj) (let ((newobj (send obj add-prop-pol-complex prop))) ; insert here a for-each to retrieve previous props (set! obj newobj) (add-gp obj (car prop) (cadr prop)))) ((anim-pol-complex? obj) (let ((newobj (send (anim-pol-complex-pol obj) add-prop-pol-complex prop))) (add-gp obj (car prop) (cadr prop)) (set! obj (make-anim-pol-complex obj (anim-pol-complex-id obj) (anim-pol-complex-tStart obj) (anim-pol-complex-tEnd obj)))))) obj)) props) obj)) (#t (plasm-exception `( "$:[|TT,OR~[[|ISSTRING,TT|],ISSEQOF:[|ISSTRING,TT|]]|]" ,x))))) (#t (plasm-exception `( "$:[|TT,OR~[[|ISSTRING,TT|],ISSEQOF:[|ISSTRING,TT|]]|]" ,x)))))) ; Funzioni gestione string ; Simone Portuesi ; notare che char non esiste ma solo stringhe lungezza uno come era in PLaSM clisp ; il problema è che con l'attuale sintassi non si potrebbero differenziare i due, ; a livello applicativo per ora non ci sono problemi, tuttavia un domani ci potrebbe essere utile un char scheme ; era gia definita ; (isstring string?) (ischar ,(lambda (c) (and (string? c) (eq? (string-length c) 1)))) (string ,(lambda (seq) (if (and (every (lambda (c) (string? c)) seq)) (apply string-append seq) (plasm-exception `("STRING" "(IsSeqOf:IsString)" ,seq))) ) ) (charseq ,(lambda (str) (if (string? str) (map string (string->list str)) (plasm-exception `("CHARSEQ" "IsString" ,str)) ) ) ) (ord ,(lambda (c) (if (and (string? c) (eq? (string-length c) 1)) (char->integer (string-ref c 0)) (plasm-exception `("ORD" "IsChar" ,c))))) (char ,(lambda (i) (if (and (integer? i) (>= i 0) (<= i 255)) (string (integer->char i)) (plasm-exception `("CHAR" "(IsInt OR GE:1 OR LE:255)" ,i))))))) (define (pol-complex? pol) (is-a? pol pol-complex% )) ; ************************* ; *** Giorgio Scorzelli * ; ************************* (define (pol-complex-space-dim pol) (if (pol-complex? pol) (send pol get-npol-dim) (plasm-exception `( "POL-COMPLEX-SPACE-DIM" "IsPol" ,pol)))) ;------------------------------------------------------------------------- ; Two Plasm Function ;------------------------------------------------------------------------- (Plasm_Parser " DEF as = IF:; DEF ac = IF:; ") ;-------------------------------------------------------------------------- ; All Plasm geometric function defined by Scheme code ;------------------------------------------------------------------------- (if *USE_GEOMETRY* (for-each (lambda (elem) (if (pair? (car elem)) (for-each (lambda (name) (*env* 'def name (eval `(lambda () ,(cadr elem))))) (car elem)) (*env* 'def (car elem) (eval `(lambda () ,(cadr elem)))))) `( ; Geometric Funcions ; Affine Transfomations (put aliases too) (check dims) ; (check dims) ;---------------------------------------------------------------------------------------------; ; Simone Portuesi, overloaded for animated pol complex (t (lambda (axis) (cond ((integer? axis) (lambda (args) (if (number? args) (lambda (pol) (cond ((pol-complex? pol) (send pol translate-pol-complex (1- axis) (exact->inexact args))) ((anim-pol-complex? pol) (make-anim-pol-complex (send (anim-pol-complex-pol pol) translate-pol-complex (1- axis) (exact->inexact args)) (anim-pol-complex-id pol) (anim-pol-complex-tStart pol) (anim-pol-complex-tEnd pol))) (#t (plasm-exception `( "T:(IsInt:IsNum)" "IsPol AND IsAnimPol" ,pol))))) (plasm-exception `( "T:IsInt" "IsNum" ,args))))) ((and (pair? axis) (every integer? axis)) (lambda (args) (if (and (pair? args) (every number? args) (eq? (length axis) (length args))) (lambda (pol) (if (or (pol-complex? pol) (anim-pol-complex? pol)) (let ((res (if (anim-pol-complex? pol) (anim-pol-complex-pol pol) pol))) (for-each (lambda (ax arg) (set! res (send res translate-pol-complex (1- ax) (exact->inexact arg)))) axis args) (if (anim-pol-complex? pol) (make-anim-pol-complex res (anim-pol-complex-id pol) (anim-pol-complex-tStart pol) (anim-pol-complex-tEnd pol)) res)) (plasm-exception `( "T:(IsSeqOf:IsInt):(IsSeqOf:IsNum)" "IsPol AND IsAnimPol" ,pol)))) (plasm-exception `( "T:(IsSeqOf:IsInt)" "IsSeqOf:IsNum" ,args))))) (#t (plasm-exception `( "T" "IsInt OR IsSeqOf:IsInt" ,axis)))))) ;---------------------------------------------------------------------------------------------; ; Simone Portuesi, overloaded for animated pol complex (s (lambda (axis) (cond ((integer? axis) (lambda (args) (if (number? args) (lambda (pol) (cond ((pol-complex? pol) (send pol scale-pol-complex (1- axis) (exact->inexact args))) ((anim-pol-complex? pol) (make-anim-pol-complex (send (anim-pol-complex-pol pol) scale-pol-complex (1- axis) (exact->inexact args)) (anim-pol-complex-id pol) (anim-pol-complex-tStart pol) (anim-pol-complex-tEnd pol))) (#t (plasm-exception `( "S:(IsInt:IsNum)" "IsPol AND IsAnimPol" ,pol))))) (plasm-exception `( "S:IsInt" "IsNum" ,args))))) ((and (pair? axis) (every integer? axis)) (lambda (args) (if (and (pair? args) (every number? args) (eq? (length axis) (length args))) (lambda (pol) (if (or (pol-complex? pol) (anim-pol-complex? pol)) (let ((res (if (anim-pol-complex? pol) (anim-pol-complex-pol pol) pol))) (for-each (lambda (ax arg) (set! res (send res scale-pol-complex (1- ax) (exact->inexact arg)))) axis args) (if (anim-pol-complex? pol) (make-anim-pol-complex res (anim-pol-complex-id pol) (anim-pol-complex-tStart pol) (anim-pol-complex-tEnd pol)) res)) (plasm-exception `( "S:(IsSeqOf:IsInt):(IsSeqOf:IsNum)" "IsPol AND IsAnimPol" ,pol)))) (plasm-exception `( "S:(IsSeqOf:IsInt)" "IsSeqOf:IsNum" ,args))))) (#t (plasm-exception `( "S" "IsInt OR IsSeqOf:IsInt" ,axis)))))) ; estenere &| rivedere (h (lambda (axis) ; single axis S:IsNum (cond ((integer? axis) ; args vector (lambda (args) ; all the row vector (cond ((and (list? args) (every number? args)) (lambda (pol) (if (and (pol-complex? pol) (eq? (length args) (pol-complex-space-dim pol))) (send pol shear-pol-complex (1- axis) args) (plasm-exception `( "H:IsInt:(IsSeqOf:IsNum)" "IsPol OR ??")) ))) ; other forms (#t (plasm-exception `( "H:IsInt" "IsSeqOf:IsNum"))) ))) ; other forms (#t (plasm-exception `( "H" "IsInt")))))) ;---------------------------------------------------------------------------------------------; ; Simone Portuesi, overloaded for animated pol complex ; (check dims) (r (lambda (axis) (cond ((and (pair? axis) (every integer? axis) (eq? 2 (length axis))) (lambda (args) (if (number? args) (lambda (pol) (cond ((pol-complex? pol) (send pol rotate-pol-complex (1- (car axis)) (1- (cadr axis)) (exact->inexact args) )) ((anim-pol-complex? pol) (make-anim-pol-complex (send (anim-pol-complex-pol pol) rotate-pol-complex (1- (car axis)) (1- (cadr axis)) (exact->inexact args)) (anim-pol-complex-id pol) (anim-pol-complex-tStart pol) (anim-pol-complex-tEnd pol))) (#t (plasm-exception `( "R:IsInt:IsNum" "IsPol AND IsAnimPol" ,pol))))) (plasm-exception `( "R:IsInt" "IsNum" ,args))))) ((and (pair? axis) (every (lambda (ax) (and (pair? ax) (every integer? ax) (eq? 2 (length ax)))) axis)) (lambda (args) (if (and (pair? args) (every number? args) (eq? (length axis) (length args))) (lambda (pol) (if (or (pol-complex? pol) (anim-pol-complex? pol)) (let ((res (if (anim-pol-complex? pol) (anim-pol-complex-pol pol) pol))) (for-each (lambda (ax arg) (set! res (send res rotate-pol-complex (1- (car ax)) (1- (cadr ax)) (exact->inexact arg)))) axis args) (if (anim-pol-complex? pol) (make-anim-pol-complex res (anim-pol-complex-id pol) (anim-pol-complex-tStart pol) (anim-pol-complex-tEnd pol)) res)) (plasm-exception `( "R:(IsSeqOf:IsInt):(IsSeqOf:IsNum)" "IsPol AND IsAnimPol" ,pol)))) (plasm-exception `( "R:(IsSeqOf:IsInt)" "IsSeqOf:IsNum" ,args))))) (#t (plasm-exception `( "R" "IsInt AND IsSeqOf:IsInt" ,axis)))))) (omat (lambda (mat) (if (and (list? mat) (every (lambda (lst) (and (list? lst) (= (length mat) (length (car mat)) (length lst)) (every number? lst))) mat)) (lambda (pol) (if (and (pol-complex? pol) (eq? (1+ (pol-complex-space-dim pol)) (length mat))) ;Giorgio Scorzelli ;(pol-complex-mat pol mat) (send pol pol-complex-mat mat) (plasm-exception `( "OMAT:(IsSeqOf:IsSeqOf:IsNum)" "IsPol AND ??")))) (plasm-exception `( "OMAT" "IsSeqOf:IsSeqOf:IsNum (??)"))))) (mkpol (lambda (three_seq) (if (and (pair? three_seq) (= 3 (length three_seq)) (every pair? three_seq) (every (lambda (point) (and (pair? point) (= (length (car (car three_seq))) (length point)) (every number? point))) (car three_seq)) (every (lambda (cell) (and (pair? cell) (every integer? cell))) (cadr three_seq)) (every (lambda (pol) (and (pair? pol) (every integer? pol))) (caddr three_seq))) (apply make-pol (list (map (lambda (seq) (map exact->inexact seq)) (car three_seq)) (cadr three_seq) (caddr three_seq))) (plasm-exception `( "MkPol" "[|IsSeqOf:((IsSeqOf:IsNum) AND (?)),IsSeqOf:((IsSeqOf:IsInt),IsSeqOf:((IsSeqOf:IsInt)|]" ,three_seq))))) (ukpol (lambda (apol) (if (pol-complex? apol) (send apol unmake-pol) (plasm-exception `( "UkPol" "IsPol" ,apol))))) (ukpolf (lambda (apol) (if (pol-complex? apol) (send apol unmake-pol-f) (plasm-exception `( "UkPolF" "IsPol" ,apol))))) ;---------------------------------------------------------------------------------------------; ; Simone Portuesi, overloaded for animated pol complex ; inserire errori (struct (lambda (seq) (let ((res #f) (has_anims #f)) (for-each (lambda (elem) (cond ((pol-complex? elem) (if res (set! res (cons elem res)) (set! res (list elem)))) ((anim-pol-complex? elem) (begin (set! has_anims #t) (if res (set! res (cons elem res)) (set! res (list elem))))) ((procedure? elem) (if res (begin (if (eq? 1 (length res)) (set! res (list (elem (car res)))) (if has_anims (set! res (list (elem (anim-struct-pol-complex res)))) (set! res (list (elem (struct-pol-complex res)))))) (if (anim-pol-complex? (car res)) (set! has_anims #t))) #f)) (#t (plasm-exception `( "STRUCT" "IsSeqOf:(IsPol OR IsFun)" ,seq))))) (reverse seq)) (if (not res) (plasm-exception `( "STRUCT" "IsSeqOf:(IsPol OR IsFun)" ,seq))) (if (eq? 1 (length res)) (car res) (if has_anims (anim-struct-pol-complex res) (struct-pol-complex res) ))))) (min (lambda (coord-list) (let ((coord (if (list? coord-list) coord-list (list coord-list)))) (lambda (pol) (if (pol-complex? pol) (let ((mins (car (send pol get-limits coord 'min)))) (if (= (length mins) 1) (car mins) mins)) (plasm-exception `( "MIN:IsSeq" "IsPol" ,pol))))))) (max (lambda (coord-list) (let ((coord (if (list? coord-list) coord-list (list coord-list)))) (lambda (pol) (if (pol-complex? pol) (let ((maxs (car (send pol get-limits coord 'max)))) (if (= (length maxs) 1) (car maxs) maxs)) (plasm-exception `( "MAX:IsSeq" "IsPol" ,pol))))))) (med (lambda (coord-list) (let ((coord (if (list? coord-list) coord-list (list coord-list)))) (lambda (pol) (if (pol-complex? pol) (let ((meds (car (send pol get-limits coord 'med)))) (if (= (length meds) 1) (car meds) meds)) (plasm-exception `( "MED:IsSeq" "IsPol" ,pol))))))) (size (lambda (coord-list) (let ((coord (if (list? coord-list) coord-list (list coord-list)))) (lambda (pol) (if (pol-complex? pol) (let ((sizes (car (send pol get-limits coord 'size)))) (if (= (length sizes) 1) (car sizes) sizes)) (plasm-exception `( "SIZE:IsSeq" "IsPol" ,pol))))))) (embed (lambda (dim) (if (and (integer? dim) (>= dim 0)) (lambda (pol) (if (pol-complex? pol) (send pol embed-pol-complex dim) (plasm-exception `( "EMBED:IsInt" "IsPol" ,pol)))) (plasm-exception `( "EMBED" "IsIntPos" ,dim))))) (bspize (lambda (pol) (if (pol-complex? pol) (send pol bspize) (plasm-exception `( "bspize" "IsPol" ,pol))))) ;---------------------------------------------------------------------------------------------; ; Simpone Portuesi temporary, this way an animated pol complex is a pol complex to user functions ; but not to library ones, that have to explicitly enabled (ispol (lambda (pol) (or (pol-complex? pol) (anim-pol-complex? pol)))) (isanimpol anim-pol-complex?) (ispurepol pol-complex?) ;---------------------------------------------------------------------------------------------; (ispoldim #f) ;wrapper SimplexC++ (rn (lambda (pol) (if (pol-complex? pol) (send pol get-npol-dim) (plasm-exception `( "RN" "IsPol"))))) ; renamed dim -> dimc (dimc (lambda (pol) (if (pol-complex? pol) (send pol get-dpol-dim) (plasm-exception `( "DIM" "IsPol"))))) ;(pquote #f) ; che serve? wrapper SimplexC++? ;(grid #f) ; che serve? wrapper SimplexC++? (square_hole #f) ; che serve? wrapper SimplexC++? (polygon #f) ;wrapper SimplexC++ ;---------------------------------------------------------------------------------------------; ; Simone Portuesi, overloaded for animated pol complex (export_vrml (lambda (pol) (if (or (pol-complex? pol) (anim-pol-complex? pol)) (let ((file_name "") (newpol (if (anim-pol-complex? pol) (anim-pre-export pol) pol))) (display "File name? (default untitled.wrl) > ") (set! file_name (read)) (cond ((string? file_name) (export-vrml-pol-complex-with-info newpol file_name 'file)) ((symbol? file_name) (export-vrml-pol-complex-with-info newpol (symbol->string file_name) 'file)) (#t (export-vrml-pol-complex-with-info newpol "untitled.wrl" 'file))) (newline) pol) (plasm-exception `( "EXPORT_VRML" "IsPol" ,pol))))) ;---------------------------------------------------------------------------------------------; ; Simone Portuesi, overloaded for animated pol complex (export_vrml_with_name (lambda (pol) (if (or (pol-complex? pol) (anim-pol-complex? pol)) (lambda (file_name) (if (or (string? file_name) (symbol? file_name)) (let ((newpol (if (anim-pol-complex? pol) (anim-pre-export pol) pol))) (cond ((string? file_name) (export-vrml-pol-complex-with-info newpol file_name 'file)) ((symbol? file_name) (export-vrml-pol-complex-with-info newpol (symbol->string file_name) 'file)) (#t (export-vrml-pol-complex-with-info pol "untitled.wrl" 'file))) pol) (plasm-exception `( "EXPORT_VRML_WITH_NAME" "IsSymbol" ,file_name)))) (plasm-exception `( "EXPORT_VRML_WITH_NAME" "IsPol" ,pol))) )) (export_stream (lambda (pol) (if (pol-complex? pol) (lambda (file_name) (if (or (string? file_name) (symbol? file_name)) (begin (cond ((string? file_name) (export-vrml-pol-complex-with-info pol file_name 'stream)) ((symbol? file_name) (export-vrml-pol-complex-with-info pol (symbol->string file_name) 'stream)) (#t (export-vrml-pol-complex-with-info pol "untitled.wrl" 'stream))) pol) (plasm-exception `( "EXPORT_STREAM" "IsSymbol" ,file_name)))) (plasm-exception `( "EXPORT_STREAM" "IsPol" ,pol))) )) (export_svg_with_name (lambda (pol) (if (pol-complex? pol) (if (equal? 2 (send pol get-npol-dim)) (lambda (width) (if (number? width) (lambda (file_name) (if (string? file_name) (begin (export-svg-pol-complex-with-info pol file_name width) pol) (plasm-exception `( "EXPORT_SVG_WITH_NAME" "IsString" ,file_name)))) (plasm-exception `( "EXPORT_SVG_WITH_NAME" "IsNumber" ,width)))) (plasm-exception `( "EXPORT_SVG_WITH_NAME" "get-npol-dim!=2" ,pol))) (plasm-exception `( "EXPORT_SVG_WITH_NAME" "IsPol" ,pol))))) ; Vanno scelti i parametri da passare in input alla funzione dell'mzwrap ; (export_flash_with_name (lambda (pol) (if (pol-complex? pol) (if (equal? 2 (send pol get-npol-dim)) (lambda (width) (if (number? width) (lambda (file_name) (if (string? file_name) (begin (export-flash-pol-complex-with-info pol file_name width) pol) (plasm-exception `( "EXPORT_FLASH_WITH_NAME" "IsString" ,file_name)))) (plasm-exception `( "EXPORT_FLASH_WITH_NAME" "IsNumber" ,width)))) (plasm-exception `( "EXPORT_FLASH_WITH_NAME" "get-npol-dim!=2" ,pol))) (plasm-exception `( "EXPORT_FLASH_WITH_NAME" "IsPol" ,pol))))) ; Da riscrivere il test dei parametri (commentato) ;//NB qui pollist è una lista di liste di poliedri! (export_flash_animation_with_name (lambda (pollist) ; (if (pol-complex? pol) ; (if (equal? 2 (send pol get-npol-dim)) (lambda (width) (if (number? width) (lambda (file_name) (if (string? file_name) (lambda (frame_rate) (if (number? frame_rate) (begin (export-flash-animation-with-info pollist file_name width frame_rate) pollist) (plasm-exception `( "EXPORT_FLASH_ANIMATION_WITH_NAME" "IsNumber" ,frame_rate)))) (plasm-exception `( "EXPORT_FLASH_ANIMATION_WITH_NAME" "IsString" ,file_name)))) (plasm-exception `( "EXPORT_FLASH_ANIMATION_WITH_NAME" "IsNumber" ,width)))) ;(plasm-exception `( "EXPORT_FLASH_ANIMATION_WITH_NAME" "get-npol-dim!=2" ,pol))) ;(plasm-exception `( "EXPORT_FLASH_WITH_NAME" "IsPol" ,pol))))) )) ;---------------------------------------------------------------------------------------------; ; Stefano Francesi : insertion of names directly into polyhedral complex ; ;---------------------------------------------------------------------------------------------; (insert-name ,(lambda (pol) (if (pol-complex? pol) (lambda (name) (if (symbol? name) (insert_name (list pol name)) (plasm-exception `( "INSERT-NAME" "IsSymbol" ,name)))) (plasm-exception `( "INSERT-NAME" "IsPol" ,pol))) )) ;---------------------------------------------------------------------------------------------; ; Stefano Francesi : free memory allocated by polyhedral complex ; ;---------------------------------------------------------------------------------------------; (delete-polcomplex ,(lambda (pol) (if (pol-complex? pol) (delete_polcomplex pol) (plasm-exception `( "DELETE-POLCOMPLEX" "IsPol" ,pol))) )) ;---------------------------------------------------------------------------------------------; ; Stefano Francesi : loading of PLaSM scripts & libraries ; ; Alberto Paoluzzi : moved the interpreter call outside the source file ;---------------------------------------------------------------------------------------------; (load (lambda (file_name) (if (or (string? file_name) (symbol? file_name)) (cond ((string? file_name) (eval-plasm (read-string 20000000 (open-input-file file_name)))) ((symbol? file_name) (eval-plasm (read-string 20000000 (open-input-file (symbol->string file_name)))))) (plasm-exception `( "LOAD" "IsString OR IsSimbol" ,file_name))) )) (loadlib (lambda (lib_name) (if (or (string? lib_name) (symbol? lib_name)) (cond ((string? lib_name) (loadlib (eval-plasm (read-string 20000000 (open-input-file file_name))) )) ((symbol? lib_name) (loadlib (symbol->string lib_name)))) (plasm-exception `( "LOADLIB" "IsString OR IsSimbol" ,lib_name))) )) ;---------------------------------------------------------------------------------------------; ; Stefano Francesi : displaying of an help screen ; ;---------------------------------------------------------------------------------------------; (help ,(lambda (value) (plasmhelp (current-output-port)))) ;---------------------------------------------------------------------------------------------; ; Giorgio Scorzelli : want prune or unprune? TO BE USED ONLY INTERNALLY ; ;---------------------------------------------------------------------------------------------; (unprune ,(lambda (value) (set! *DO-UNPRUNE* value))) ;---------------------------------------------------------------------------------------------; ; Stefano Francesi : useful aliases to export functions ; ;---------------------------------------------------------------------------------------------; (export ((get-env *env* 'raise) (get-env *env* 'export_vrml_with_name))) (vrml ((get-env *env* 'raise) (get-env *env* 'export_vrml_with_name))) (svg ((get-env *env* 'raise) (get-env *env* 'export_svg_with_name))) (flash ((get-env *env* 'raise) (get-env *env* 'export_flash_with_name))) (flashani ((get-env *env* 'raise) (get-env *env* 'export_flash_animation_with_name))) ;---------------------------------------------------------------------------------------------; ; Stefano Francesi : printing of internal representation of complexes ; ;---------------------------------------------------------------------------------------------; (dump (lambda (pol) (if (pol-complex? pol) (send pol dump-pol-complex) (plasm-exception `( "DUMP" "IsPol" ,pol))) )) (dumprep (lambda (pol) (if (pol-complex? pol) (lambda (rep) ; 0 = ONVERTICES, 1 = ONFACES (if (and (integer? rep) (or (eq? 1 rep) (eq? 0 rep))) (send pol dump-pol-complex-with-rep (list rep)) (plasm-exception `( "DUMPREP:IsPol" "IsInt 0 OR 1" ,rep)))) (plasm-exception `( "DUMPREP" "IsPol" ,pol))) )) ; Giorgio Scorzelli ; Save a binary Plasm FILE!!! ;(save ; (lambda (pol) ; (lambda (filename) ; (let ((port (open-output-file filename))) ; (display (send pol dump-pol-complex) port) ; (close-output-port port) ; (display "*** File saved ***"))))) (save (lambda (pol) (lambda (filename) (begin (send pol save-xml filename) (display "*** File saved ***"))))) ; Giorgio Scorzelli ; Open a binary Plasm File!!! ; (open ; (lambda (filename) ; (let* ((port (open-input-file filename)) ; (s (read-string 20000000 port)) ; max 20 mb! ; (pol (xml-pol-import s))) ; (close-input-port port) ; pol))) (open (lambda (filename) (xml-pol-import filename))) ;Giorgio Scorzelli (view (lambda (pol) (begin (send pol viewopengl)))) ; aggiungere !!! ;(PRINT (ARG) (PROGN (FORMAT T "~%~%~A~%~%" (PRINT-PLASM ARG)) ARG)) (print (lambda (pol) (begin (Plasm_Printer pol #t) pol))) ; (inspect (lambda (pol) ; (if (pol-complex? pol) ; (pol-complex-inspect pol) ; (plasm-exception `( "INSPECT" "IsPol" ,pol))))) ; (simplex (lambda (dim) (if (and (integer? dim) (not (negative? dim))) (build-pol-complex-simplex dim) (plasm-exception `( "SIMPLEX" "IsIntNotNeg" ,dim))))) (skeleton (lambda (a_int) (if (integer? a_int) (lambda (pol) (if (pol-complex? pol) (send pol skeleton a_int) (plasm-exception `( "SKELETON:IsInt" "IsPol" ,pol)))) (plasm-exception `( "SKELETON" "IsInt" ,a_int))))) (cmap (lambda (afun) (if (procedure? afun) (lambda (apol) (if (pol-complex? apol) (send apol map-pol-complex afun) (plasm-exception `( "CMAP:IsFun" "IsPol" ,apol)))) (plasm-exception `( "CMAP" "IsFun" ,afun))))) (ccuboid (lambda (dims) (if (and (list? dims) (every number? dims)) (do ((res (build-pol-complex-cube (length dims)) (send res scale-pol-complex cnt (exact->inexact (aref dims cnt)))) (cnt 0 (1+ cnt))) ((>= cnt (length dims)) res)) (plasm-exception `( "CCUBOID" "IsSeqOf:IsNum" ,dims))))) (join (lambda (seq) (cond ((pol-complex? seq) (send seq join '())) ((every pol-complex? seq) (send (car seq) join (cdr seq))) (#t (plasm-exception `( "JOIN" "IsPol OR IsSeqOf:IsPol" seq)))))) ;; Giorgio Scorzelli ;; Operazioni booleane modificate per operazioni N-arie ((intersectionpr &) (lambda (seq) (begin (set! *DO-UNPRUNE* #f) (if (every pol-complex? seq) (send (car seq) and (cdr seq)) (plasm-exception `( "INTERSECTION" "IsSeqOf:IsPol" seq)))))) (intersection (lambda (seq) (begin (set! *DO-UNPRUNE* #t) (if (every pol-complex? seq) (send (car seq) and (cdr seq)) (plasm-exception `( "INTERSECTION" "IsSeqOf:IsPol" seq)))))) ((unionpr \|) ; alias is '+' (defined in 'add' function) (lambda (seq) (begin (set! *DO-UNPRUNE* #f) (if (every pol-complex? seq) (send (car seq) or (cdr seq)) (plasm-exception `( "UNION" "IsSeqOf:IsPol" seq)))))) (union (lambda (seq) (begin (set! *DO-UNPRUNE* #t) (if (every pol-complex? seq) (send (car seq) or (cdr seq)) (plasm-exception `( "UNION" "IsSeqOf:IsPol" seq)))))) ((differencepr) ; alias is '-' (defined in 'sub' function) (lambda (args) (begin (set! *DO-UNPRUNE* #f) (cond ((and (pair? args) (every pol-complex? args) (> (length args) 1)) (let loop ([hh (car args)][tt (cdr args)]) (if (and (pair? tt) (>= (length tt) 2)) (loop (send hh diff (list (car tt))) (cdr tt)) (send hh diff (list (car tt))))) ) ((and (pair? args) (every pol-complex? args)) args) (#t (plasm-exception `( "DIFFERENCE" "IsSeqOf:IsPol" args))))))) (difference (lambda (args) (begin (set! *DO-UNPRUNE* #t) (cond ((and (pair? args) (every pol-complex? args) (> (length args) 1)) (let loop ([hh (car args)][tt (cdr args)]) (if (and (pair? tt) (>= (length tt) 2)) (loop (send hh diff (list (car tt))) (cdr tt)) (send hh diff (list (car tt))))) ) ((and (pair? args) (every pol-complex? args)) args) (#t (plasm-exception `( "DIFFERENCE" "IsSeqOf:IsPol" args))))))) ((sdifferencepr \^) (lambda (args) (begin (set! *DO-UNPRUNE* #f) (cond ((and (pair? args) (every pol-complex? args) (> (length args) 1)) (send (let loop1 ([hh (car args)][tt (cdr args)]) (if (and (pair? tt) (>= (length tt) 2)) (loop1 (send hh or (list (car tt))) (cdr tt)) (send hh or (list (car tt))))) diff (list (let loop2 ([hh (car args)][tt (cdr args)]) (if (and (pair? tt) (>= (length tt) 2)) (send (send (send (loop2 (send hh and (list (car tt))) (cdr tt)) or (list (loop2 (car tt) (cdr tt)))) or (list (loop2 hh (cdr tt)))) or (list (send hh and (list (car tt))))) (send hh and (list (car tt))))))) ) ((and (pair? args) (every pol-complex? args)) args) (#t (plasm-exception `( "SDIFFERENCE" "IsSeqOf:IsPol" args))))))) ((sdifference XOR) (lambda (args) (begin (set! *DO-UNPRUNE* #t) (cond ((and (pair? args) (every pol-complex? args) (> (length args) 1)) (send (let loop1 ([hh (car args)][tt (cdr args)]) (if (and (pair? tt) (>= (length tt) 2)) (loop1 (send hh or (list (car tt))) (cdr tt)) (send hh or (list (car tt))))) diff (list (let loop2 ([hh (car args)][tt (cdr args)]) (if (and (pair? tt) (>= (length tt) 2)) (send (send (send (loop2 (send hh and (list (car tt))) (cdr tt)) or (list (loop2 (car tt) (cdr tt)))) or (list (loop2 hh (cdr tt)))) or (list (send hh and (list (car tt))))) (send hh and (list (car tt))))))) ) ((and (pair? args) (every pol-complex? args)) args) (#t (plasm-exception `( "SDIFFERENCE" "IsSeqOf:IsPol" args))))))) ((pdifference PDIFF) (lambda (seq) (begin (set! *DO-UNPRUNE* #t) (if (every pol-complex? seq) (send (car seq) pdiff (cdr seq)) (plasm-exception `( "PDIFFERENCE" "IsSeqOf:IsPol" seq)))))) (complementpr (lambda (args) (begin (set! *DO-UNPRUNE* #f) (if (every pol-complex? args) (send (send (car args) or (cdr args)) diff (list (send (car args) and (cdr args)))) (plasm-exception `( "COMPLEMENT" "IsSeqOf:IsPol" args)))))) (complement (lambda (args) (begin (set! *DO-UNPRUNE* #t) (if (every pol-complex? args) (send (send (car args) or (cdr args)) diff (list (send (car args) and (cdr args)))) (plasm-exception `( "COMPLEMENT" "IsSeqOf:IsPol" args)))))) (power (lambda (two_pols) (if (and (pair? two_pols) (eq? 2 (length two_pols)) (every pol-complex? two_pols)) (send (car two_pols) power (cadr two_pols)) (plasm-exception `( "POLC_DIFF" "[|IsPol,IsPol|]" ,two_pols)) ))) ;---------------------------------------------------------------------------------------------; ; Stefano Francesi : Properties ; ;---------------------------------------------------------------------------------------------; (showprop (lambda (obj) (if (has-property? obj) (plasm-list-gp obj) (plasm-exception `( "SHOWPROP" "has-property?" ,obj))) )) ;---------------------------------------------------------------------------------------------; ; Stefano Francesi : Copy of Polyhedral Complexes ; ;---------------------------------------------------------------------------------------------; (copy (lambda (pol) (if (pol-complex? pol) (send pol copy-pol-complex) (plasm-exception `( "COPY" "IsPol" ,pol))))) ;---------------------------------------------------------------------------------------------; ; Stefano Francesi : Decomposition of Polyhedral Complexes ; ;---------------------------------------------------------------------------------------------; (depol (lambda (pol) (if (pol-complex? pol) (send pol depol) (plasm-exception `( "DEPOL" "IsPol" ,pol))))) ;---------------------------------------------------------------------------------------------; ; Stefano Francesi : Functional environment ; ; First support for environment serialization ; ;---------------------------------------------------------------------------------------------; ;(shownames (display (map (lambda (a) (car a)) (*env* 'list)))) ;---------------------------------------------------------------------------------------------; ; Simone Portuesi, added animation functions (move (lambda (fun) (if (procedure? fun) (lambda (configurations) (if (pair? configurations) (lambda (time-behaviour) (if (and (pair? time-behaviour) (every (lambda (a) (and (number? a) (>= a 0))) time-behaviour) (= (length configurations) (length time-behaviour))) (anim-move fun configurations time-behaviour) (plasm-exception `( "MOVE:IsFun:IsSeq" "IsSeqOf:IsNum OR equal length" ,time-behaviour)))) (plasm-exception `( "MOVE:IsFun" "IsSeq" ,configurations)))) (plasm-exception `( "MOVE:IsFun" ,fun))))) (animation (lambda (anims) (if (and (pair? anims) (not (null? anims)) (every (lambda (a) (or (anim-pol-complex? a) (pol-complex? a) (procedure? a))) anims)) ((get-env *env* 'struct) anims) (plasm-exception `( "ANIMATION" "IsSeqOf:IsAnimPolc" ,anims))))) (loop (lambda (times) (if (and (integer? times) (> times 0)) (lambda (anim) (if (anim-pol-complex? anim) (anim-loop #t times anim) (plasm-exception `( "OUTERLOOP:IsInt" "IsAnimPolc" ,anim)))) (plasm-exception `( "OUTERLOOP" "IsInt" ,times))))) (outerloop (lambda (times) (if (and (integer? times) (> times 0)) (lambda (anim) (if (anim-pol-complex? anim) (anim-loop #f times anim) (plasm-exception `( "INNERLOOP:IsInt" "IsAnimPolc" ,anim)))) (plasm-exception `( "INNERLOOP" "IsInt" ,times))))) (warp (lambda (times) (if (and (number? times) (not (= times 0))) (lambda (anim) (if (anim-pol-complex? anim) (anim-warp #t (exact->inexact times) anim) (plasm-exception `( "WARP:IsNum" "IsAnimPolc" ,anim)))) (plasm-exception `( "WARP" "IsNum" ,times))))) (outerwarp (lambda (times) (if (and (number? times) (not (= times 0))) (lambda (anim) (if (anim-pol-complex? anim) (anim-warp #f (exact->inexact times) anim) (plasm-exception `( "WARP:IsNum" "IsAnimPolc" ,anim)))) (plasm-exception `( "WARP" "IsNum" ,times))))) (shift (lambda (t) (if (number? t) (lambda (anim) (if (anim-pol-complex? anim) (anim-shift (exact->inexact t) anim) (plasm-exception `( "SHIFT:IsNum" "IsAnimPolc" ,anim)))) (plasm-exception `( "SHIFT" "IsNum" ,t))))) ; Hacked to overload for FLASH frame ; To be removed when a semantical integration between the two is done (frame (lambda (pols) (cond ((pol-complex? pols) (lambda (times) (cond ((and (pair? times) (not (null? times)) (every number? times) (= 2 (length times))) (anim-frame (list pols) times)) ((and (integer? times) (> times 0) (not (eq? (*env* 'get 'frameflash) '|§_np_§|))) (((get-env *env* 'frameflash) pols) times)) (#t (plasm-exception `( "FRAME:(IsPolc)" "[|IsNum,IsNum|]" ,times)))))) ((and (pair? pols) (not (null? pols)) (every pol-complex? pols)) (lambda (times) (if (and (pair? times) (not (null? times)) (every number? times) (= (length pols) (- (length times) 1))) (anim-frame pols times) (plasm-exception `( "FRAME:(IsSeqOf:IsPolc)" "IsSeqOf:IsNum" ,times))))) (#t (plasm-exception `( "FRAME" "IsSeqOf:IsPolc" ,pols)))))) ;--------------------------------------------------------------------------------------------- ))) (define (sendop args op unpr) (begin (set! *DO-UNPRUNE* unpr) (cond ((and (pair? args) (every pol-complex? args) (> (length args) 1)) (let loop ([hh (car args)][tt (cdr args)]) (if (and (pair? tt) (>= (length tt) 2)) (case op (("and") ((loop (send hh and (list (car tt))) (cdr tt)))) (("or") ((loop (send hh or (list (car tt))) (cdr tt))))) (case op (("and") ((send hh and (list (car tt))))) (("or") (send hh or (list (car tt)))))))) ((and (pair? args) (every pol-complex? args)) args) (#t (plasm-exception `( "INTERSECTION" "IsSeqOf:IsPol" args)))))) ;-------------------------------------------- ; Giorgio Scorzelli ; la matrice e` gia` omogenea ;-------------------------------------------- ; def mat (m::(IsSeqOf:(IsSeqOf:IsNum))) = ; OMAT:(AR:) ; WHERE ; LAST_ROW=AR:<##:(LEN:M):<0>,1> ; END; (define being_used_by #f) ;----------------------------------------------------------------------------------------- ; Plasm other geometric function defined by Plasm code ;----------------------------------------------------------------------------------------- (if *USE_GEOMETRY* (begin (Plasm ;_Parser " DEF && (permutations::IsSeqOf:IsSeq) (pols::IsSeqOf:IsPol) = (fix ~ STRUCT ~ AA:& ~ CART ~ AA:SplitCells): (AA:MAP:maps (AA:APPLY ~ TRANS) AA:(EX:<0,1000000>):pols) WHERE maps = AA:(CONS ~ AA:SEL):permutations, fix = MKPOL ~ [S1,S2, AA:[ID]~CAT~S3] ~ UKPOL END; def quote = IF:, STRUCT~CAT~(AA:(IF:))>, Signal~[K:'QUOTE',K:'IsSeqOf:IsNum',ID]>; def mat (m::(IsSeqOf:(IsSeqOf:IsNum))) = OMAT:m; DEF LOCATE (pol::IsPol; i::IsIntPos; distances::IsSeqOf:IsReal) = (STRUCT ~ CAT ~ DISTR):; DEF BOX (index_s::TT) (pol::IsPol) = STRUCT: WHERE mins = MIN:index_s:pol , sizes = SIZE:index_s:pol, translation = t:(if::index_s) END; DEF ALIGN (inf::TT) (pol1,pol2::IsPol) = (STRUCT ~ fun): WHERE fun = IF::inf END; DEF align1 (index,pos1,pos2::TT) (pol1,pol2::IsPol) = > WHERE trans_val = SUB::pol1 ,APPLY::pol2> END; DEF TOP (Pol1, Pol2 ::IsPol) = ALIGN:<<3,MAX,MIN>,<1,MED,MED>,<2,MED,MED>>:; DEF BOTTOM (Pol1, Pol2 ::IsPol) = ALIGN:<<3,MIN,MAX>,<1,MED,MED>,<2,MED,MED>>:; DEF LEFT (Pol1, Pol2 ::IsPol) = ALIGN:<<1,MIN,MAX>>:; DEF RIGHT (Pol1, Pol2 ::IsPol) = ALIGN:<<1,MAX,MIN>>:; DEF UP (Pol1, Pol2 ::IsPol) = ALIGN:<<2,MAX,MIN>>:; DEF DOWN (Pol1, Pol2 ::IsPol) = ALIGN:<<2,MIN,MAX>>:; DEF split_2pi1 (i::IsIntPos) = (AA:* ~ DISTR):, 2 * PI/i>; DEF isEmpty(pol::IsPol) = (isNull~S1~ukpol):pol; DEF PMAP (f::OR~[isSeqOf:IsFun, IsFun]) = MKPOL ~ [AA:fun ~ S1, S2, S3] ~ UKPOL WHERE fun = IF:< IsSeqOf:IsFun, CONS, ID >:f END; DEF MAP = PMAP; DEF PCUBOID (dims::IsSeqOf:IsNumPos) = (MKPOL ~ UKPOL ~ IF:< C:EQ:1~LEN, S1, * >):(AA:(QUOTE~[ID]):dims); DEF CUBOID = PCUBOID; DEF dimp = if:; DEF DIM = dimp; ") (display "Loading most psmlib files...") ;--------------------------------------------------------------------- ; Alberto Paoluzzi: loading libraries from ; "Geometric Programming for Computer Aided Design", Wiley, 2003 ;--------------------------------------------------------------------- (loadlib "vectors") (loadlib "animation") (loadlib "colors") (loadlib "transfinite") (loadlib "curves") (loadlib "derivatives") (loadlib "drawtree") (loadlib "flash") (loadlib "general") (loadlib "operations") (loadlib "primitives") (loadlib "myfont") (loadlib "shapes") ; (loadlib "spikexml") (loadlib "splines") (loadlib "strings") (loadlib "surfaces") (loadlib "text") (loadlib "viewmodels") (newline) )) ;--------------------------------------------------------------------- ; Prepare to get users' new definition ;--------------------------------------------------------------------- (define *u_env* (make-env make-def (make-hash-assoc))) (define *env* (union-env *f_env* *u_env*))