view src/scheme/shell.scm @ 8:5e3cbbf173aa tip

Reorganise some more

(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))