[foo-cvs] foo/elkfoo/scm/control/node Makefile.am,NONE,1.1 node-function-database.foo,NONE,1.1 node-functionalities.foo,NONE,1.1 node.foo,NONE,1.1

[Martin R. <ru...@us...>]

Update of /cvsroot/foo/foo/elkfoo/scm/control/node
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv6585/control/node

Added Files:
	Makefile.am node-function-database.foo 
	node-functionalities.foo node.foo 
Log Message:
initial checkin of scheme files, control, tools

--- NEW FILE: node-functionalities.foo ---
(define (node? obj)
  (let ((name))
    (if (instance? obj)
	  (begin
		(set! name (class-name obj))
	  	(while (and (not (null? name))
	  	     	    (not (equal? name 'Node)))
		    (set! name (get-SuperName (eval name))))
		(if (equal? name 'Node) #t #f)) #f)))

(define (node-class? obj)
  (let ((name))
    (if (class? obj)
	  (begin
		(set! name (class-name obj))
	  	(while (and (not (null? name))
	  	     	    (not (equal? name 'Node)))
		    (set! name (get-SuperName (eval name))))
		(if (equal? name 'Node) #t #f)) #f)))

(define (make-node . args)
  (let ((nody))
    (if (and (not (null? args))
     	     (node-class? (car args)))
	(begin
	   (set! nody (make-an-instance (car args)))
	   (set! args (cdr args)))
	(set! nody (make-instance Node)))
    (if (not (null? args)) (apply send (append (list nody 'set-fields) args)))
     nody))

(define (compute-node obj . args)
   (if (node? obj) (apply send (append (list obj 'compute) args))
   		   (error 'compute-node "Not a Node : ~a"obj)))
(define (node . args)
   (compute-node (apply make-node args)))

(define (describe-node obj)
   (if (node? obj) (send obj 'get-Description)
		   (prn "This Object is not a Node")))

(define add-Node-Function
  (macro (name body . argms)
    (send (make-instance Node) 'set-Function-db name)
    (if (not (null? argms))
       (if (and (equal? 'lambda (car body))
       		(symbol? (cadr body)))
       `(define-method Node (,name . ARGUMENTS)
	   (let* ((aux) (Numb (send self 'get-NumResults)) (Args)
		  (End (+ Index Numb)))
	    (while (< Index End)
		(send self 'Increment-Index)
		(set! aux (append aux (list (apply ,body ARGUMENTS))))
		(set! Result (append Result (last-pair aux))))
	    (if (= Numb 1) (car aux) aux)))
       `(define-method Node (,name ,@argms)
	   (let* ((aux) (Numb (send self 'get-NumResults)) (Args)
		  (End (+ Index Numb)))
	    (while (< Index End)
		(send self 'Increment-Index)
		(set! aux (append aux (list (apply ,body (list ,@argms)))))
		(set! Result (append Result (last-pair aux))))
	    (if (= Numb 1) (car aux) aux))))

       `(define-method Node (,name . garbage)
	   (let* ((aux) (Numb (send self 'get-NumResults)) (Args)
		  (End (+ Index Numb)))
	    (while (< Index End)
		(send self 'Increment-Index)
		(set! aux (append aux (list ,body)))
		(set! Result (append Result (last-pair aux))))
	    (if (= Numb 1) (car aux) aux))))))

(define add-Function
    (macro (Classname name body . argms)
	(if (not (eval `(node-class? ,Classname)))
	     (error 'add-Node-Function "Not a Node subclass (~s)" Classname))
	(send (eval `(make-an-instance ,Classname)) 'set-Function-db name)
     (if (not (null? argms))
       (if (and (equal? 'lambda (car body))
       		(symbol? (cadr body)))
       `(define-method ,Classname (,name . ARGUMENTS)
	   (let* ((aux) (Numb (send self 'get-NumResults)) (Args)
		  (End (+ Index Numb)))
	    (while (< Index End)
		(send self 'Increment-Index)
		(set! aux (append aux (list (apply ,body ARGUMENTS))))
		(set! Result (append Result (last-pair aux))))
	    (if (= Numb 1) (car aux) aux)))
       `(define-method ,Classname (,name ,@argms)
	   (let* ((aux) (Numb (send self 'get-NumResults)) (Args)
		  (End (+ Index Numb)))
	    (while (< Index End)
		(send self 'Increment-Index)
		(set! aux (append aux (list (apply ,body (list ,@argms)))))
		(set! Result (append Result (last-pair aux))))
	    (if (= Numb 1) (car aux) aux))))

       `(define-method ,Classname (,name)
	   (let* ((aux) (Numb (send self 'get-NumResults)) (Args)
		  (End (+ Index Numb)))
	    (while (< Index End)
		(send self 'Increment-Index)
		(set! aux (append aux (list ,body)))
		(set! Result (append Result (last-pair aux))))
	    (if (= Numb 1) (car aux) aux))))))

--- NEW FILE: node.foo ---
(require 'oops)
(define-class Node (class-vars Function-db) (instance-vars Data
							   Args
							   Funx
							   Result
							   Partial-Result
							   (Index -1)
							   (NumResults 1)))

(define-method Node (reset)
    (set! Partial-Result '())
    (set! Result '())
    (set! Index -1))

(define-method Node (get-Function-db)
  (let ((aux) (name (eval (class-name self))))
     (for-each
      (lambda (x)
       (if (method-known? x name) (set! aux (cons x aux)))) Function-db)
    (reverse aux)))
(define-method Node (get-Data) Data)
(define-method Node (get-Args) Args)
(define-method Node (get-Funx) Funx)
(define-method Node (get-Result) Result)
(define-method Node (get-Partial-Result) Partial-Result)
(define-method Node (get-Index) Index)
(define-method Node (get-NumResults) NumResults)

(define-method Node (set-Data Lst)
  (send self 'set-Partial-Result '())
  (set! Data Lst))
(define-method Node (set-Args . Lst)
;  (send self 'set-Partial-Result '())
  (set! Args Lst))
(define-method Node (set-Funx Fun)
  (let ((fundb (send self 'get-Function-db)) (fun) (args) (aux))
     (send self 'set-Args)
     (send self 'set-Partial-Result '())
     (cond
     	((procedure? Fun)			(set! Funx Fun))
	((member Fun fundb)			(set! Funx Fun))
	((and (pair? Fun)
	      (or (member (car Fun) fundb)
	          (procedure? (car Fun))))	(set! Funx Fun))
	(#t
		(prn "WARNING Unable to set this Function : "Fun) #f))))
     			  
(define-method Node (set-Result Lst)         (set! Result Lst))
(define-method Node (set-Partial-Result Lst) (set! Partial-Result Lst))
(define-method Node (set-Index Val)          (set! Index Val))
(define-method Node (set-NumResults Val)
   (if (and (number? Val)
    	    (>= Val 1))
	(set! NumResults Val)
	(if (and (pair? Val)
		 (number? (car Val))
		 (>= (car Val) 1)) (set! NumResults (car Val))
				   (error 'Node "set-NumResults ~s" Val))))
(define-method Node (set-Function-db Lst)
  (let ((fundb (send self 'get-Function-db)))
    (set! Function-db
    	(if (member Lst fundb) fundb (append fundb (list Lst))))))


(define-method Node (Increment-Index)
    (send self 'set-Index (+ 1 (send self 'get-Index))))


(define-method Node (set-fields . args)
  (let ((flg #f) (aux))

    (set! aux (assq 'Funx args))
    (if aux (begin
    		(send self 'set-Funx (cadr aux))
		(set! flg #t)))
    (set! aux (assq 'Data args))
    (if aux (begin
    		(send self 'set-Data (cadr aux))
		(set! flg #t)))
    (set! aux (assq 'Args args))
    (if aux (begin
    		(apply send (append (list self 'set-Args) (cdr aux)))
		(set! flg #t)))
    (set! aux (assq 'NumResults args))
    (if aux (begin
    		(send self 'set-NumResults (cadr aux))
		(set! flg #t)))
    (if flg #t
     	     (if (not (null? args))
	     		 (apply send (append (list self 'set-Args) args)))
	     #t)))

(define-method Node (calculate body . args)
   (let* ((aux  (send self 'get-Result))
	  (Data (send self 'get-Data))
	  (Numb (send self 'get-NumResults))
	  (End  (+ (send self 'get-Index) Numb))
	  (indx) (aux1)
	  (args (if (not (null? args)) (car args) '())))

      (while (< (send self 'get-Index) End)
        (send self 'Increment-Index)
	(set! indx (send self 'get-Index))
	(set! aux1
	  (append aux1 (list
	    (cond
	     ((null? args)	   (apply body (list Data indx aux)))
	     ((= (length args) 1) (apply body (list (car args) Data indx aux)))
	     (#t		(apply body (list args Data indx aux)))))))

	(send self 'set-Result (append Result (last-pair aux1)))
	(if (= Numb 1) (set! aux1 (car (last-pair aux1))))
	(set! aux (send self 'get-Result)))
      aux1))

(define-method Node (node-next)
   (let ((fundb (send self 'get-Function-db))
   	 (meth (send self 'get-Funx))
   	 (args (send self 'get-Args))
	 (Numb (send self 'get-NumResults))
	 (Resl))

    (if (not (null? meth))
      (begin
       (set! Resl
    	(if (procedure? meth)
	    (if (not (null? args)) (send self 'calculate meth args)
		     (send self 'calculate meth))
	    (if (null? args) (send self meth)
	    		     (apply send (append (list self meth) args)))))
			     Resl))))

(define-method Node (compute . args)
   (if (not (null? args)) (apply send (append (list self 'set-fields) args)))
   (send self 'node-next))


(define-method Node (describe-Function Val)
   (newline)
   (if (method-known? Val (eval (class-name self)))
	(begin
	    (prn "**"Val"**")
	    (pp (eval Val)))
	(prn "! Unknown Function ! :"Val)))

(define-method Node (get-Description)
  (let ((Cname (class-name self)))
    (newline)
    (if (equal? Cname 'Node)
    		(prn " This is a Node Object. ")
		(prn " This is a Node Object of the Subclass :"Cname))
    (newline)
    (prn " Function  : "(send self 'get-Funx))
    (prn " Data      : "(send self 'get-Data))
    (prn " Arguments : "(send self 'get-Args))
    (newline)
    (prn " Number of Results :"(send self 'get-NumResults))
    (newline)
    (prn " :: Internal state :: ")
    (newline)
    (prn "      Index         :"(send self 'get-Index))
    (prn "      Result        :"(send self 'get-Result))
    (prn "      Parial-Result :"(send self 'get-Partial-Result))))

--- NEW FILE: Makefile.am ---
# foo/elkfoo/scm/control/node/Makefile.am
# 2004 rumori

# $Id: Makefile.am,v 1.1 2004/08/07 22:53:01 rumori Exp $

NULL = 

pkgnode_DATA = $(ELKFOO_NODE_FILES)

pkgnodedir = $(pkgdatadir)/control/node

ELKFOO_NODE_FILES = \
	node-function-database.foo \
	node-functionalities.foo \
	node.foo \
	$(NULL)

--- NEW FILE: node-function-database.foo ---
;
;;
;;;	GENERAL FUNCTIONS
;;
;
(define (rand01) (/ (random) 2147483647))

(define (randint a z) (+ a (* (- z a) (rand01))))

(define (alea a z) (inexact->exact (round (randint a z))))

(define (mk-ordrlst lnz . start)
   (let* ((i (if (and (not (null? start))
   		      (number? (car start))) (car start) 0))
   	 (sign (if (>= lnz i) - +))
   	 (resl '()))
      (while (not (= lnz i))
	(set! resl (cons lnz resl)) (set! lnz (sign lnz 1)))
      (cons i resl)))

(define (make-ordrlst lnz . data)
  (let* ((i (if (and (not (null? data))
                     (number? (car data))) (car data) 0))
         (q (if (and (not (null? data))
                     (= (length data) 2)
                     (number? (cadr data))) (cadr data) 1))
         (sign (if (>= lnz i) - +))
         (conn (if (>= lnz i) <= >=))
         (resl '()))
    (while (not (conn lnz i))
           (set! resl (cons lnz resl))
           (set! lnz (sign lnz q)))
    (cons i resl)))

(define (eliminate el lst)
   (let ((rsl) (flg #t))
      (for-each
        (lambda (x)
	   (if (and flg
	   	   (equal? x el)) (set! flg #f)
		   		  (set! rsl (append rsl (list x))))) lst)
     rsl))

(define (eliminate-all el lst)
   (let ((rsl))
      (for-each
        (lambda (x)
	   (if (not (equal? x el)) (set! rsl (append rsl (list x))))) lst)
     rsl))

(define (Lstshuffle lst)
    (let* ((lnz (1- (length lst))) (resl) (el))
       (while (not (null? lst))
       	   (set! el (nth lst (alea 0 lnz)))
	   (set! lst (eliminate el lst))
	   (set! resl (cons el resl))
	   (set! lnz (1- lnz)))
       resl))

(define (Lstshuffle.old lst)
    (let ((aux) (lnz (length lst)) (resl) (el))
       (while (< (length resl) lnz)
       	   (set! aux (alea 0 (- lnz 1)))
	   (set! el (nth lst aux))
	   (while (member el resl)
		(set! aux (alea 0 (- lnz 1)))
		(set! el (nth lst aux)))
	   (set! resl (cons el resl)))
       resl))
;
;;
;;;	SELECTION FUNCTIONS
;;
;
(define (aleasel Lst) (let ((lnz (- (length Lst) 1))) (nth Lst (alea 0 lnz))))

(define (seriessel Lst Dum)
  (let ( (lnz (1- (length Lst))) (elm))
    (if (null? Dum)
	(set! Dum (Lstshuffle (mk-ordrlst lnz)))
        (if (= (length Dum) 1)
	   (begin (set! elm (car Dum))
	   	  (set! Dum (Lstshuffle (mk-ordrlst lnz)))
	   	  (while (and (> lnz 1) (= elm (car Dum)))
		  	(set! Dum (Lstshuffle (mk-ordrlst lnz))))
		  (set! Dum (cons elm Dum)))))
    (set! elm (car Dum))
    (list (nth Lst elm) (cdr Dum))))

(define (nextsel Lst indx) (let* ((lnz (length Lst))
			   	  (aux1 (if (>= indx lnz) (- lnz 1) indx)))
			      (list-ref Lst aux1)))

(define (circsel Lst indx) (let* ((lnz (length Lst))
			   	  (aux1 (modulo indx lnz)))
			      (list-ref Lst aux1)))

(define (mirrorsel Lst indx) (let* ((lnz (- (length Lst) 1))
				    (lenz2 (* 2 lnz))
			    	    (mod (modulo indx lenz2))
			    	    (aux1 (if (> mod lnz) (- lenz2 mod) mod)))
			      (list-ref Lst aux1)))

(define (intpsel Lst indx totn)
   (let* ((lnz (length Lst))
	  (aux1 (/ lnz totn)))
     (if (> indx totn) (set! indx totn))
     (if (>= lnz totn) (list-ref Lst indx)
		  (list-ref Lst (inexact->exact (truncate (* aux1 indx)))))))


(define (groupsel Lst Dum mini maxi)
  (let ((num) (val) (nval) (Lstaux) (Numaux1) (Numaux2) (flg #f))
    (if (null? Dum)
	(set! Numaux1 (map (lambda (x) (+ x mini))
	    				(mk-ordrlst (- maxi mini))))
	(set! val     (car Dum))
	(set! num     (cadr Dum))
	(set! Numaux1 (caddr Dum))
	(set! Numaux2 (cadddr Dum))
	(set! Lstaux  (car (cddddr Dum))))
    (if (not (null? num))
	(set! num (if (= num 2) '() (- num 1)))
	(set! num (seriessel Numaux1 Numaux2))
	(set! Numaux2 (cadr num))
	(set! num (car num))
	(if (= num 1) (set! num '()))
	(set! val (seriessel Lst Lstaux))
	(set! Lstaux (cadr val))
	(set! val (car val)))
	(list val num Numaux1 Numaux2 Lstaux)))

(define (alcircsel Lst indx)
   (let* ((lnz (length Lst))
          (aux1 (modulo indx lnz))
	  (aux2 (list-head Lst aux1))
	  (lnz2 (length aux2)))
      (if (= 0 lnz2) '()
		      (list-ref aux2 (alea 0 (1- lnz2))))))

;
;;
;;;	INTERPOLATION FUNCTIONS
;;
;


(define (linint xi xa ya xz yz)
    (cond
       ((= xi xa)	ya)
       ((= xi xz)	yz)
       (#t		(+ ya (* (- yz ya) (/ (- xi xa) (- xz xa)))))))

(define (expint xi xa ya xz yz pnd)
    (cond
       ((= xi xa)	ya)
       ((= xi xz)	yz)
       (#t		(expon (/ (- xi xa) (- xz xa)) ya yz pnd))))

(define (lstlinint xi xa lsta xz lstz)
   (map (lambda (ya yz) (linint xi xa ya xz yz)) lsta lstz))

(define (lstexpint xi xa lsta xz lstz pnd)
   (map (lambda (ya yz) (expint xi xa ya xz yz pnd)) lsta lstz))

(define (stepfun xi xa ya xz yz) (if (>= xi xz) yz ya))

(define (stadint xi xa ya xz yz)
   (let ((x) (y) 
         (x1 (+ (/ (- xz xa) 3) xa))
         (x2 (+ (* 2 (/ (- xz xa) 3)) xa))
	 (lsta (append (make-list 5 ya) (make-list 5 yz))))
      (set! x (if (< xi x2) 0 (/ (* 9 (- xi x2)) (- xz x2))))
      (set! y (if (< xi x1) (/ (* 9 (- xi xa)) (- x1 xa)) 9))
      (nth lsta (alea x y))))

(define (lststadint xi xa lsta xz lstz)
    (map (lambda (ya yz) (stadint xi xa ya xz yz)) lsta lstz))

(define (filtre Lst Min Max)
 (let ((rsl '()))
  (for-each (lambda (x) (if (and (>= x Min)
  				 (<= x Max)) (set! rsl (cons x rsl)))) Lst)
  (reverse rsl)))

;
;;
;;;	IMPLEMENTATION AS NODE FUNCTIONS
;;
;

(add-Node-Function ALEA	(aleasel Data))
(add-Node-Function ALCIRC (alcircsel Data Index))
(add-Node-Function CIRC	(circsel Data Index))
(add-Node-Function EXPINT
    (lambda (x)
	(expint x (car Data) (cadr Data) (caddr Data) (cadddr Data)
					 (car (cddddr Data))))
    Xi)
(add-Node-Function GIVEDATA (identity Data))
(add-Node-Function GROUP
    (lambda (x y)
	(let ((aux1 (groupsel Data Partial-Result x y)))
	    (set! Partial-Result aux1) (car aux1)))
    Minimum-RepetitionRange Maximum-RepetitionRange)
(add-Node-Function INTPSEL
    (lambda (x)
    	(intpsel Data Index x)) Number-Results)
(add-Node-Function INTSERIES
    (lambda X
	(let ((X1 (car X)) (X2 (cadr X)))
	    (if (not (null? X2)) (mk-ordrlst X1 X2)
	 	   (mk-ordrlst X1))))
    Values)
(add-Node-Function LININT
    (lambda (x)
	(linint x (car Data) (cadr Data) (caddr Data) (cadddr Data)))
    Xi)
(add-Node-Function LSTEXPINT
    (lambda (x)
	(lstexpint x (car Data) (cadr Data) (caddr Data) (cadddr Data)
	    					(car (cddddr Data))))
    Xi)
(add-Node-Function LSTLININT
    (lambda (x)
	(lstlinint x (car Data) (cadr Data) (caddr Data) (cadddr Data)))
    Xi)
(add-Node-Function LSTSTADINT
    (lambda (x)
	(lststadint x (car Data) (cadr Data) (caddr Data) (cadddr Data)))
    Xi)
(add-Node-Function MIRROR (mirrorsel Data Index))
(add-Node-Function NEXT	(nextsel Data Index))
(add-Node-Function SERIES
    (let ((aux1 (seriessel Data Partial-Result)))
	(set! Partial-Result (cadr aux1)) (car aux1)))
(add-Node-Function SHUFFLE (Lstshuffle Data))
(add-Node-Function STADINT
    (lambda (x)
	(stadint x (car Data) (cadr Data) (caddr Data) (cadddr Data)))
    Xi)
(add-Node-Function STEP
    (lambda (x)
	(stepfun x (car Data) (cadr Data) (caddr Data) (cadddr Data)))
    Xi)