comparison src/scheme/shell.scm @ 0:bf79fb79ee13

Initial Mercurial check in.

+(import "samer.core.*")
+(import "samer.core.types.*")
+(import "samer.silk.*")
+
+(define true #t)
+(define false #f)
+
+
+(define (for-it proc it)
+	(if (.hasNext it)
+		(begin
+			(proc (.next it))
+			(for-it proc it))))
+
+
+;;; directory handling
+
+(define (abs-path path) (.getCanonicalPath (java.io.File. path)))
+(define (pwd) (abs-path "."))
+;(define .. "..")
+(define (cd dir)
+	(System.setProperty "user.dir" (abs-path dir))
+	(System.getProperty "user.dir"))
+(define (ls . paths)
+	(array->list (.listFiles (java.io.File.
+		(if (null? paths) "." (first paths))
+	))))
+
+(define (filter p? l) (reverse (filter-rev p? l ())))
+(define (filter-rev p? l a)
+	(if (null? l) a
+		(let ((h (car l)) (t (cdr l)))
+			(if (p? h)
+				(filter-rev p? t (cons h a))
+				(filter-rev p? t a)))))
+
+;(define push Shell.push)
+;(define pop Shell.pop)
+(define env Shell.env)
+(define cat string-append)
+
+(define (pr-env)
+	(for-it
+		(lambda (b)
+			(display (.name b))
+			(display "=")
+			(write (.get b X.ObjectCodec$ null))
+			(display "\n"))
+		(.data (Shell.env))))
+
+
+(define (vbls) (.getViewables (get "ViewableManager")))
+(define (pr-vbls)
+	(for-it
+		(lambda (v)
+			(display (.toString (.getNode v)))
+			(newline))
+		(vbls)))
+
+(define (it->list it)
+	(define (accum it list)
+		(if (not (.hasNext it))
+			list
+			(accum it (cons (.next it) list))))
+	(reverse (accum it ())))
+
+(define (view-vector L name)
+	(Shell.expose (javax.swing.JScrollPane. (javax.swing.JList. L)) name)
+	null)
+
+(define (view-list L name) (view-vector (list->vector L) name))
+
+(define (print l)
+	(define (print-list l n)
+		(if (null? l)
+			(newline)
+			(begin
+				(display (cat (number->string n) ": " (first l)))
+				(newline)
+				(print-list (rest l) (+ n 1)))))
+	(if (list? l)
+		(print-list l 0)
+		(if (vector? l)
+			(print (vector->list l))
+			(begin (display l) (newline))
+		)
+	)
+)
+
+;;; ------------ some macros ------------
+
+(define node (macro (name . body)
+	`(begin
+		(Shell.push ,name)
+		(let ((a
+			(tryCatch
+				(begin . ,body)
+				(lambda (ex) (Shell.pop) (throw ex)))))
+			(Shell.pop)
+			a))))
+
+; ; (define node (macro (name . body)
+; ; 	`(let*	(	(a (Shell.push ,name))
+; ; 					(b (begin . ,body))		)
+; ; 		(Shell.pop) b
+; ; 	))
+; ; )
+
+;;; this creates a named node as a child of (.getNode parent)
+(define (child parent name) (Node. name (.getNode parent)))
+
+;;; alternative version
+;(define node (macro (name . body)
+;	`(Shell.push ,name)
+;	`(let ((b (begin . ,body)))
+;		(Shell.pop) b)
+;))
+
+(define observer (macro body `(samer.silk.SilkObserver. (lambda (o a) ,@body))))
+(define on-change (macro (o . body)
+	`(.addObserver ,o (samer.silk.SilkObserver. (lambda (o a) ,@body)))
+))
+
+;;; ---------------------------------------
+
+(define-method (exec (agent Agent) cmd) (.execute agent cmd (Shell.env)))
+(define-method (exec (vbl Viewable) cmd) (.execute (.getAgent vbl) cmd (Shell.env)))
+(define-method (exec (mat samer.maths.Matrix) cmd) (.execute (.getAgent mat) cmd (Shell.env)))
+(define (matexec matrix cmd) (exec (samer.maths.MatrixAgent. matrix) cmd))
+
+(define (viewable name) (.getViewable (get "ViewableManager") (.abs (Shell.env) name)))
+(define (edit-vbl vbl)
+	(Shell.showDialogFor
+		(.getComponent (.getViewer vbl))
+		(.getLabel vbl)))
+
+(define (cur-node) (.node (env)))
+(define (set nm vl) (X.store nm vl))
+(define (put nm vl) (Shell.put nm vl))
+(define (get nm) (Shell.get nm))
+(define (pr-viewables)	(.listViewables (get "ViewableManager")))
+(define (exit) 		(.dispatch (get "AgentManager") "exit" (Shell.env)))
+(define-method (expose) (.dispatch (get "AgentManager") "expose" (Shell.env)))
+(define-method (expose (name String)) (Shell.expose (viewable name)))
+(define-method (expose (vbl Viewable)) (Shell.expose (.getViewer vbl) (.fullName (.getNode vbl))))
+(define-method (expose (vwr Viewer) (name String)) (Shell.expose vwr name))
+
+; another kind of store
+;(define (store nm obj) (.store (Shell.env) nm obj X.StringCodec$))
+
+(define (hclicker canvas_name rcname)
+	(define rc (viewable rcname))
+	(define cl (Clicker. (get canvas_name) (+ (.getMax rc) 1) 1))
+	(.setXReceiver cl rc))
+
+(define (vclicker canvas_name rcname)
+	(define rc (viewable rcname))
+	(define cl (Clicker. (get canvas_name) 1 (+ (.getMax rc) 1)))
+	(.setYReceiver cl rc))
+