home *** CD-ROM | disk | FTP | other *** search
/ Usenet 1994 October / usenetsourcesnewsgroupsinfomagicoctober1994disk1.iso / altsrc / articles / 11157 < prev    next >
Lisp/Scheme  |  1994-08-23  |  25KB  |  801 lines
  1. Path: wupost!uhog.mit.edu!news.kei.com!travelers.mail.cornell.edu!newstand.syr.edu!galileo.cc.rochester.edu!ceas.rochester.edu!ceas.rochester.edu!not-for-mail
  2. From: weisberg@kirchoff.ee.rochester.edu (Jeff Weisberg)
  3. Newsgroups: alt.sources
  4. Subject: jlisp interpreter part02 / 10
  5. Followup-To: alt.sources.d
  6. Date: 23 Aug 1994 11:07:28 -0400
  7. Organization: University of Rochester School of Engineering and Applied Science
  8. Lines: 788
  9. Message-ID: <Jlisp94Aug23part02@ee.rochester.edu>
  10. References: <Jlisp94Aug23Notice@ee.rochester.edu>
  11. NNTP-Posting-Host: kirchoff.ee.rochester.edu
  12.  
  13.  
  14. Archive-name: jlisp-1.03
  15. Submitted-by: weisberg@ee.rochester.edu
  16.  
  17. #! /bin/sh
  18. # 0. this is shell archive
  19. # 1. Remove everything above the #! /bin/sh line
  20. # 2. Save the resulting text in a file
  21. # 3. Execute the file with /bin/sh (not csh)
  22. # 4. Or use your favorite variant of unshar
  23. # 5. To overwrite existing files use "sh -c"
  24. #
  25. # Created by: weisberg@ankara on Tue Aug 23 10:50:47 EDT 1994
  26. #
  27. # This is part 02
  28.  
  29. if test -f jlisp-1.03/lisp/init.cf.jl -a "$1" != "-c" ; then
  30.     echo "will not overwrite jlisp-1.03/lisp/init.cf.jl"
  31. else
  32.     echo "    x - jlisp-1.03/lisp/init.cf.jl (5406 bytes)"
  33.     sed 's/^X//' > jlisp-1.03/lisp/init.cf.jl << \CEST_TOUT
  34. X
  35. X;;;; Copyright (c) 1994 Jeff Weisberg
  36. X;;;; see the file "License"
  37. X
  38. X;;;; $Id: init.cf.jl,v 1.16 94/08/23 07:19:15 weisberg Exp Locker: weisberg $
  39. X
  40. X(set! .hash_table_size 7)    ; most often a small table will suffice
  41. X                 ; this was determined empirically
  42. X(set! .box_size 1024)        ; allocate cells at a time
  43. X(set! .gc_thresh (* .box_size 50))     ; keep threshhold high
  44. X
  45. X
  46. X;;; yes, defun/defmac could possibly have been combound, but
  47. X;;; it becomes an unreadable mess of `,`,',`',`',,`,```,,',,,
  48. X
  49. X;;; for space savings the docstr and defined-in-file props can be removed
  50. X
  51. X(define defun
  52. X  "(defun name args [docstr] body...) Define a Function"
  53. X  (macro (func argl &rest args)
  54. X     (let* ((docstr (car args))
  55. X        (body (cdr args)))
  56. X       (if (stringp docstr)
  57. X           #t
  58. X         (set! docstr "Not Documented")
  59. X         (set! body args))
  60. X       `(progn
  61. X          (define ,func ,docstr
  62. X        ,(cons lambda (cons argl body)))
  63. X          (set-props! ,func (cons
  64. X                 (cons 'defined-in-file ,*current-file*)
  65. X                 (get-props ',func)))
  66. X          ,func            ; retval
  67. X          ))))
  68. X
  69. X(define defmac
  70. X  "(defmac name args [docstr] body...) Define a macro"
  71. X  (macro (func argl &rest args)
  72. X     (let* ((docstr (car args))
  73. X        (body (cdr args)))
  74. X       (if (stringp docstr)
  75. X           #t
  76. X         (set! docstr "Not Documented")
  77. X         (set! body args))
  78. X       `(progn
  79. X          (define ,func ,docstr
  80. X          ,(cons macro (cons argl body)))
  81. X          (set-props! ,func (cons
  82. X                 (cons 'defined-in-file ,*current-file*)
  83. X                 (get-props ',func)))
  84. X          ,func            ; retval
  85. X          ))))
  86. X
  87. X(defmac defvar (sym val &optional doc)
  88. X  "(defvar var initvalue [docstring]) defines var as initvalue only if var is undefined"
  89. X  (if (definedp sym)
  90. X      `()
  91. X    `(define ,sym ,val ,doc)))
  92. X
  93. X(defun print argl
  94. X  "(print args...) print the args on stdout"
  95. X  (while (not (nullp argl))
  96. X    (display (car argl))
  97. X    (set! argl (cdr argl))))
  98. X
  99. X(defun newline (&optional port)
  100. X  "(newline [port]) output a newline [to a specified port]"
  101. X  (display ?\n port))
  102. X
  103. X(defvar load-path
  104. X  "load-path  list of directories to search for lisp files"
  105. X  (list
  106. X   "%LOCALLISP%"
  107. X   "%LISPDIR%"
  108. X   "%ETCDIR%"         ; start grasping at straws
  109. X   "%SRCDIR%/lisp"
  110. X   "%SRCDIR%/jlisp"
  111. X   "%SRCDIR%/lib" ))
  112. X
  113. X(defvar load-extensions
  114. X  "load-extensions  list of extensions to try for lisp files"
  115. X  (list
  116. X   ".jl" 
  117. X   ".jlisp"))
  118. X
  119. X(defvar *load:echo*    #f)  ; echo filenames as loaded
  120. X(defvar *load:verbose* #f)  ; echo each exp of the file as it is read
  121. X
  122. X(defvar *builtin-load* load)
  123. X(defvar *current-file* "init")
  124. X
  125. X;;; redefine load, the builtin is just a minimal stub
  126. X;;; this is a macro, as it must execute in the current env frame
  127. X(defmac load (file)
  128. X  "(load file) load a file"
  129. X  (let* ((efn (eval file))
  130. X     (fp (cond
  131. X          ((inputportp efn) efn)
  132. X          ((stringp efn) (let ((foo ())
  133. X                   bar
  134. X                   baz
  135. X                   (l (append '(()) load-path))           ; try as given first
  136. X                   (e ()))
  137. X                   ;; search for the file
  138. X                   (while (and (nullp foo) (not (nullp l)))
  139. X                 (set! bar (if (stringp (car l))
  140. X                           (strcat (car l) "/" efn)
  141. X                         efn))
  142. X                 (set! e (append '(()) load-extensions))  ; as given first
  143. X                 (while (and (nullp foo) (not (nullp e)))
  144. X                   (set! baz (car e))
  145. X                   ;; saved in file so we can access it later if need be
  146. X                   (set! file (if (stringp baz)    
  147. X                          (strcat bar baz)
  148. X                        bar))
  149. X                   (set! foo (open:read file))
  150. X                   (set! e (cdr e)))
  151. X                 (set! l (cdr l)))
  152. X                   foo))
  153. X          (#t
  154. X           (funcall error "load" efn "WTA: filename or port p")))))
  155. X    (if (nullp fp)
  156. X    (funcall error "load" efn "Could not open"))
  157. X    (if (or *load:echo*
  158. X        (and (definedp 'mritool) (debug-flag 1 1)))  ;  lisp, echo
  159. X    (progn (display "Loading: ") (display file) (display ?\n)))
  160. X    ;; the following will be executed in the calling env
  161. X    `(unwind-protect
  162. X     (progn
  163. X       (set! .lineno 1)
  164. X       (set! *current-file* ,file)
  165. X       (if (catch 'error              ; catch any errors, handle below
  166. X         (catch 'eof
  167. X           (if (or *load:verbose*
  168. X               (and (definedp 'mritool) (debug-flag 1 0)))  ; lisp, verbose
  169. X               (while #t
  170. X             (eval (let ((foo (read ,fp)))
  171. X                 (display foo) (display ?\n)
  172. X                 foo)))
  173. X             (while #t
  174. X               (eval (read ,fp)))))
  175. X         #f)
  176. X           ;; handle errors
  177. X           (print "\nERROR while loading \"" ,file "\" near line " .lineno ?\n))
  178. X       (close ,fp))
  179. X       (set! *current-file* ,*current-file*) ; restore filename
  180. X       (set! .lineno ,.lineno))))            ; restore lineno
  181. X
  182. X;; load more
  183. X(load "debug.jl")
  184. X(load "autoload.jl")
  185. X(load "lib.jl")
  186. X(load "math.jl")
  187. X(load "pred.jl")
  188. X(load "cmdline.jl")
  189. X(load "repl.jl")
  190. X(load "signal.jl")
  191. X(load "unistd.jl")
  192. X; uncomment the following 2 for more scheme-itivity
  193. X(load "slib.jl")
  194. X(load "r4rs.jl")
  195. X; and one for some CL-isms
  196. X(load "cl.jl")
  197. X
  198. X(autoload expand-filename "expand.jl"   "expand ~ in filenames")
  199. X(autoload roman           "roman.jl"    "return the roman numeral represenation of the number")
  200. X(autoload bind            "bind.jl"     "bind function calls")
  201. X(autoload format          "format.jl"   "formatted output")
  202. X(autoload appropos        "all-syms.jl" "what function? by keyword")
  203. X(autoload time            "time.jl"     "how long does it take?")
  204. X
  205. X(if (definedp 'mritool)
  206. X    (progn
  207. X      (load "mritool.jl")
  208. X      (define mri:background #t)    ; used internally by initliaztion in c code
  209. X      (define mri:windows    #t)    ; ditto
  210. X      (define mri:winsys     'x)))  ; what window system are we using
  211. X
  212. X
  213. CEST_TOUT
  214.     if test `wc -c < jlisp-1.03/lisp/init.cf.jl` -ne 5406 ; then
  215.         echo "file jlisp-1.03/lisp/init.cf.jl has been corrupted (should be 5406 bytes)"
  216.     fi
  217. fi
  218. if test -f jlisp-1.03/lisp/julia.jl -a "$1" != "-c" ; then
  219.     echo "will not overwrite jlisp-1.03/lisp/julia.jl"
  220. else
  221.     echo "    x - jlisp-1.03/lisp/julia.jl (720 bytes)"
  222.     sed 's/^X//' > jlisp-1.03/lisp/julia.jl << \CEST_TOUT
  223. X
  224. X
  225. X(defmac with-output (out &rest body)
  226. X  (let ((*stdout_port* (eval out)))
  227. X    (display body *stderr_port*) (newline)
  228. X    (eval (cons progn body))))
  229. X  
  230. X(defun julia (cx cy n)
  231. X  "(julia cx cy n) draw julia set"
  232. X  (let ((zx 0)
  233. X    (zy 0)
  234. X    x
  235. X    y
  236. X    s
  237. X    (i 0)
  238. X    (out (open:write "| graph -g0 -m0 -s | plot")))
  239. X    (while (!= i n)
  240. X      (set! zx (- zx cx))
  241. X      (set! zy (- zy cy))
  242. X      (set! s (sqrt (+ (* zx zx) (* zy zy))))
  243. X      (set! x (/ (+ s zx) 2.0))
  244. X      (set! y (/ (- s zx) 2.0))
  245. X      (if (< zy 0) (set! y (- y)))
  246. X      (set! zx x)
  247. X      (set! zy y)
  248. X      (if (> (random) 500000)
  249. X      (progn
  250. X        (set! zx (- zx))
  251. X        (set! zy (- zy))))
  252. X      (format out "~A~T~A~%" zx zy)
  253. X      (set! i (+ i 1)))
  254. X    (close out)))
  255. X
  256. X
  257. X
  258. X
  259. X
  260. CEST_TOUT
  261.     if test `wc -c < jlisp-1.03/lisp/julia.jl` -ne 720 ; then
  262.         echo "file jlisp-1.03/lisp/julia.jl has been corrupted (should be 720 bytes)"
  263.     fi
  264. fi
  265. if test -f jlisp-1.03/lisp/lib.jl -a "$1" != "-c" ; then
  266.     echo "will not overwrite jlisp-1.03/lisp/lib.jl"
  267. else
  268.     echo "    x - jlisp-1.03/lisp/lib.jl (4621 bytes)"
  269.     sed 's/^X//' > jlisp-1.03/lisp/lib.jl << \CEST_TOUT
  270. X
  271. X;;;; Copyright (c) 1994 Jeff Weisberg
  272. X;;;; see the file "License"
  273. X
  274. X;;;; $Id: lib.jl,v 1.24 94/08/16 07:40:14 weisberg Exp Locker: weisberg $
  275. X
  276. X(defvar *unintered-symbol-maker-counter* 0)
  277. X
  278. X(defun cddr   (x) "(cddr x) ..."   (cdr (cdr x)))
  279. X(defun caar   (x) "(caar x) ..."   (car (car x)))
  280. X(defun cdar   (x) "(cdar x) ..."   (cdr (car x)))
  281. X(defun cadr   (x) "(cadr x) ..."   (car (cdr x)))
  282. X(defun cdddr  (x) "(cdddr x) ..."  (cdr (cddr x)))
  283. X(defun caddr  (x) "(caddr x) ..."  (car (cddr x)))
  284. X(defun cadddr (x) "(cadddr x) ..." (car (cdddr x)))
  285. X
  286. X(defun version ()
  287. X  "(version) What version are we using?"
  288. X  (display .version)
  289. X  (newline))
  290. X
  291. X(defmac docstr (s)
  292. X  "(docstr symbol) retreive the documentation from a symbol"
  293. X  (let* ((pl (if (definedp s)
  294. X         (get-props s)))
  295. X     (ds (if (listp pl)
  296. X         (assq '.docstring pl))))
  297. X    (if (consp ds)
  298. X    (cdr ds)
  299. X      "No documentation available")))
  300. X
  301. X(defun cat-file (file)
  302. X  "(cat-file file) cat a file to stdout"
  303. X  (system (strcat "cat " (expand-filename file))))
  304. X
  305. X(defun make-range (lo hi)
  306. X  "(make-range lo hi) return a list of numbers from lo to hi (inclusive)"
  307. X  (cond
  308. X   ((>= lo hi)
  309. X    (list hi))
  310. X   (#t
  311. X    (cons lo (make-range (+ lo 1) hi)))))
  312. X
  313. X(defmac define-with (name val pred prepr &optional doc)
  314. X  "(define-with name value predicate preproc [docstring])
  315. X  defines name as val and adds a few properties to the alist, for type safety
  316. X  [see also: sets!]"
  317. X
  318. X  (if (definedp name)
  319. X      `(print ',name " already defined\n")
  320. X    `(progn
  321. X       (define ,name ,val ,doc)
  322. X       (set-props! ,name (acons 'predicate ,pred
  323. X                (acons 'preproc ,prepr
  324. X                       (get-props ',name))))
  325. X       ())))
  326. X
  327. X
  328. X(defmac sets! (name val)
  329. X  "(sets! name val) sets name to val, possibly with some type checking..."
  330. X
  331. X  (if (ndefinedp name)
  332. X      `(error "sets!" ,name "not defined")
  333. X    (let* ((value (eval val))
  334. X       (pl (get-props name))
  335. X       (okp (assq 'predicate pl))
  336. X       (pp  (assq 'preproc   pl))
  337. X       (v (if (and pp (cdr pp) (nnullp (cdr pp)))
  338. X          ((cdr pp) value)
  339. X        value)))
  340. X      (if (or (not (and okp (cdr okp) (nnullp okp))) ((cdr okp) v))
  341. X      `(set! ,name ',v)
  342. X    `(error "sets!" ,val "bad value")))))
  343. X
  344. X
  345. X; SAP p. 97
  346. X(defun reverse (l)
  347. X  "(reverse list) reverse a list"
  348. X  (if (nconsp l)
  349. X      l
  350. X    (append (reverse (cdr l)) (list (car l)))))
  351. X
  352. X(defun 1+ (i)
  353. X  "(1+ i) return (+ 1 i)"
  354. X  (+ 1 i))
  355. X
  356. X(defun 1- (i)
  357. X  "(1- i) return (+ -1 i)"
  358. X  (+ -1 i))
  359. X
  360. X(defmac ++ (i)
  361. X  "(++ i) increment a number"
  362. X  `(progn
  363. X    (set! ,i (1+ ,i))
  364. X    ,i))
  365. X
  366. X(defmac -- (i)
  367. X  "(-- i) decrement a number"
  368. X  `(progn
  369. X     (set! ,i (1- ,i))
  370. X     ,i))
  371. X
  372. X(defun != (x y)
  373. X  "(!= a b) are they different?
  374. X  [see also: = < > <= >=]"
  375. X  (not (= x y)))
  376. X
  377. X(defun string->number (str &optional %input-radix%)
  378. X  "(string->number string [radix]) convert string to a number
  379. X  [see also: number->string]"
  380. X    (read (open:string str)))
  381. X
  382. X(defun number->string (n &optional %output-radix%)
  383. X  "(number->string number [radix]) convert number to a string
  384. X  [see also: string->number]"
  385. X  (let ((str (strcpy ""))
  386. X    (sp (open:string str)))
  387. X    (write n sp)
  388. X    str))
  389. X
  390. X(defun getline (&optional port)
  391. X  "(getline [port]) read in a line [from port] will return () on eof"
  392. X  (let ((s (strcpy ""))
  393. X    (e (eof-object))
  394. X    (c ()))
  395. X    (if (catch 'eof
  396. X      (while (not (or (eq c ?\n) (eq c e)))
  397. X        (set! c (getc port))
  398. X        (strappend! s c)))     ; strings magically grow
  399. X    ()
  400. X      s)))
  401. X
  402. X(defun print-stderr argl
  403. X  "(print-stderr args...) print the args on stderr"
  404. X  (while (nnullp argl)
  405. X    (display (car argl) *stderr_port*)
  406. X    (set! argl (cdr argl))))
  407. X
  408. X(defun nop argl
  409. X  "(nop) does nothing")
  410. X
  411. X(defun acons (a b c)
  412. X  (cons (cons a b) c))
  413. X
  414. X(defun cons2 (a b c)
  415. X  (cons a (cons b c)))
  416. X
  417. X
  418. X(defun memoize (fnc)
  419. X  (eval
  420. X   `(lambda (x)
  421. X      (let* ((memo '( () . () ) )
  422. X         (r (assv x memo)))
  423. X    (if r
  424. X        (cdr r)
  425. X      (let ((y (,fnc x)))
  426. X        ; (print "calculating\n")
  427. X        (append! memo (cons (cons x y) ()))
  428. X        y))))))
  429. X
  430. X
  431. X(defun die (&optional message)
  432. X  "(die [message]) print out the message and exit
  433. X  [see also: quit _quit]"
  434. X  (if (boundp message)
  435. X      (print-stderr message ?\n))
  436. X  (quit 1))
  437. X
  438. X(defun output-of-shell-command->string (cmd)
  439. X  "(output-of-shell-command->string command) return the output of running the command
  440. X  much like using `command` in the shell"
  441. X  (let ((str (strcpy ""))
  442. X    (ln #t)
  443. X    (fp  (open:read (strcat "|" cmd))))
  444. X    (while (nnullp (set! ln (getline fp)))
  445. X      (strappend! str ln))
  446. X    str))
  447. X
  448. X(defun unintered-symbol ()
  449. X  "(unintered-symbol) returns a unique unintered symbol"
  450. X  (++ *unintered-symbol-maker-counter*)
  451. X  (string->symbol (strcat "#<G-"
  452. X              (number->string *unintered-symbol-maker-counter* 36)
  453. X              ">")))
  454. X
  455. X    
  456. X
  457. X
  458. CEST_TOUT
  459.     if test `wc -c < jlisp-1.03/lisp/lib.jl` -ne 4621 ; then
  460.         echo "file jlisp-1.03/lisp/lib.jl has been corrupted (should be 4621 bytes)"
  461.     fi
  462. fi
  463. if test -f jlisp-1.03/lisp/math.jl -a "$1" != "-c" ; then
  464.     echo "will not overwrite jlisp-1.03/lisp/math.jl"
  465. else
  466.     echo "    x - jlisp-1.03/lisp/math.jl (2023 bytes)"
  467.     sed 's/^X//' > jlisp-1.03/lisp/math.jl << \CEST_TOUT
  468. X
  469. X;;;; Copyright (c) 1994 Jeff Weisberg
  470. X;;;; see the file "License"
  471. X
  472. X;;;; $Id: math.jl,v 1.8 94/08/15 15:50:10 weisberg Exp Locker: weisberg $
  473. X;; supplemental math routines/extensions
  474. X
  475. X(defvar $+$ +)
  476. X(defvar $-$ -)
  477. X(defvar $*$ *)
  478. X(defvar $/$ /)
  479. X
  480. X;;; the builtins only handle 2 args
  481. X;;; these will take any number of args
  482. X
  483. X(defun + argl
  484. X  (listop 0 $+$ argl))
  485. X
  486. X(defun * argl
  487. X  (listop 1 $*$ argl))
  488. X
  489. X(defun - argl
  490. X  (cond
  491. X   ((nullp argl) 0)
  492. X   ((nullp (cdr argl)) (- 0 (car argl)))
  493. X   (#t
  494. X    (listop (car argl) $-$ (cdr argl)))))
  495. X
  496. X(defun / argl
  497. X  (cond
  498. X   ((nullp argl) 1)
  499. X   ((nullp (cdr argl)) (/ 1 (car argl)))
  500. X   (#t
  501. X   (listop (car argl) $/$ (cdr argl)))))
  502. X
  503. X(defun listop (acc op argl)
  504. X  (while (nnullp argl)
  505. X    (set! acc (op acc (car argl)))
  506. X    (set! argl (cdr argl)))
  507. X  acc)
  508. X
  509. X(defun max argl
  510. X  (extreme > argl))
  511. X
  512. X(defun min argl
  513. X  (extreme < argl))
  514. X
  515. X(defun extreme (op argl)
  516. X  (if (nullp argl) ()
  517. X    (let ((a (car argl))
  518. X      (l (cdr argl)))
  519. X      (while (nnullp l)
  520. X    (set! a 
  521. X          (if (op a (car l))
  522. X          a
  523. X        (car l)))
  524. X    (set! l (cdr l)))
  525. X      a)))
  526. X
  527. X(defun truncate (x)
  528. X  (if (< x 0)
  529. X      (- (floor (- x)))
  530. X    (floor x)))
  531. X
  532. X(defun round (x)
  533. X  (floor (+ x .5)))
  534. X
  535. X(defun gcd (a b)
  536. X  "(gcd a b) find the greatest common denominator"
  537. X  (cond ((zerop a) b)
  538. X    (#t (gcd (% b a) a))))
  539. X
  540. X(defun lcm (a b)
  541. X  "(lcm a b) find the least common multiple"
  542. X  (abs (/ (* a b) (gcd a b))))
  543. X
  544. X(defun quotient (a b)
  545. X  "(quotient a b) the integer division of a b"
  546. X  (truncate (/ a b)))
  547. X
  548. X
  549. X;; the % operator is not garunteed to be either modulo or remainder
  550. X;; so lets play ...
  551. X
  552. X(defun remainder (a b)
  553. X  "(remainder a b) the remainder of integer division (has the sign of a)"
  554. X  (% a (abs b))) ;; is this garunteed to be right?
  555. X;; (- a (* b (quotient a b)))
  556. X
  557. X;;; note: I don't think I spelled "garunteed" correctly
  558. X;;; but ispell was no help....
  559. X
  560. X(defun modulo (a b)
  561. X  "(modulo a b) the modulous of a b (has sign of b)"
  562. X  (let ((c (% a b)))
  563. X    (cond
  564. X     ((or (and (< b 0) (> c 0))
  565. X      (and (> b 0) (< c 0)))
  566. X      (+ c b))
  567. X     (#t c))))
  568. X
  569. X
  570. CEST_TOUT
  571.     if test `wc -c < jlisp-1.03/lisp/math.jl` -ne 2023 ; then
  572.         echo "file jlisp-1.03/lisp/math.jl has been corrupted (should be 2023 bytes)"
  573.     fi
  574. fi
  575. if test -f jlisp-1.03/lisp/mouse.jl -a "$1" != "-c" ; then
  576.     echo "will not overwrite jlisp-1.03/lisp/mouse.jl"
  577. else
  578.     echo "    x - jlisp-1.03/lisp/mouse.jl (4226 bytes)"
  579.     sed 's/^X//' > jlisp-1.03/lisp/mouse.jl << \CEST_TOUT
  580. X
  581. X;;;; Copyright (c) 1994 Jeff Weisberg
  582. X;;;; see the file "License"
  583. X 
  584. X;;;; $Id: mouse.jl,v 1.4 94/08/16 16:30:06 weisberg Exp Locker: weisberg $
  585. X
  586. X;;; format of event is:
  587. X;;; #(code flags shiftmask locx locy time action string)
  588. X;;; see .../xview/win_input.h
  589. X
  590. X
  591. X;;; some (possibly) useful defines
  592. X;;; mostly from /usr/openwin/include/xview/win_input.h
  593. X
  594. X;;; event codes
  595. X(define MS_LEFT                32563 )
  596. X(define MS_MIDDLE              32564 )
  597. X(define MS_RIGHT               32565 )
  598. X(define LOC_DRAG               32515 )
  599. X                   
  600. X;;; shifmasks
  601. X(define CAPSLOCK        0      );         /* Caps Lock key                */
  602. X(define CAPSMASK        #x0001 )
  603. X(define SHIFTLOCK       1      );         /* Shift Lock key               */
  604. X(define LEFTSHIFT       2      );         /* Left-hand shift key          */
  605. X(define RIGHTSHIFT      3      );         /* Right-hand shift key         */
  606. X(define SHIFTMASK       #x000E )
  607. X(define LEFTCTRL        4      );         /* Left-hand (or only) ctrl key */
  608. X(define RIGHTCTRL       5      );         /* Right-hand control key       */
  609. X(define CTRLMASK        #x0030 )
  610. X 
  611. X(define META_SHIFT_MASK #x0040 )
  612. X(define MS_LEFT_MASK    #x0080 )
  613. X(define MS_MIDDLE_MASK  #x0100 )
  614. X(define MS_RIGHT_MASK   #x0200 )
  615. X(define MS_BUTTON_MASK  #x0380 )
  616. X(define ALTMASK         #x0400 )
  617. X
  618. X
  619. X(define mouse:start-x () "x coord. of the first point on the contour")
  620. X(define mouse:start-y () "y coord. of the first point on the contour")
  621. X(define mouse:last-x  () "x coord. of the most recent point on the contour")
  622. X(define mouse:last-y  () "y coord. of the most recent point on the contour")
  623. X(define mouse:mode    () "the current mouse mode")
  624. X(define mouse:selected 0 "currently selected contour")
  625. X
  626. X(define mouse:menu
  627. X  '(("None"       "(progn (set! mouse:mode ())            (set-left-footer-text \"None\"))")
  628. X    ("Draw"       "(progn (set! mouse:mode 'mouse:DRAW)   (set-left-footer-text \"Draw\"))")
  629. X    ("Erase"      "(progn (set! mouse:mode 'mouse:ERASE)  (set-left-footer-text \"Erase\"))")
  630. X    ("W/L"        "(progn (set! mouse:mode 'mouse:FIDDLE) (set-left-footer-text \"Adjust W/L\"))")
  631. X    ("Visine"     "(mri:visine)")    ; defined in mritool.jl
  632. X    ("Snake LOI"  "(progn (set! mouse:mode 'mouse:SELLOI) (set-left-footer-text \"Set LOI\"))")))
  633. X
  634. X
  635. X(defun mouse:handler (event)
  636. X  "(mouse:handler event) called from internally to handle mouse events"
  637. X  (let ((x (nth event 3))
  638. X    (y (nth event 4))
  639. X    (code (nth event 0)))
  640. X    ; (print "Mouse: " mouse:mode " " event ?\n)
  641. X
  642. X    (if (or (and (= MS_LEFT  code) (=  1 (& (nth event 1) 1)))                ; left & down
  643. X        (and (= LOC_DRAG code) (!= 0 (& (nth event 2) MS_LEFT_MASK)))     ; or left drag
  644. X        (eq mouse:mode 'mouse:NXTSNK))
  645. X    
  646. X    (case mouse:mode
  647. X      
  648. X          (mouse:DRAW
  649. X           (if (nullp mouse:last-x)
  650. X           ;; first point
  651. X           (progn
  652. X             (set-left-footer-text (strcat "Draw: "
  653. X                           (nth mri:buttons mouse:selected)))
  654. X             (set! mouse:start-x (set! mouse:last-x x))
  655. X             (set! mouse:start-y (set! mouse:last-y y))
  656. X             (draw-point x y mouse:selected))
  657. X         (draw-line x y mouse:last-x mouse:last-y mouse:selected)
  658. X         (set! mouse:last-x x)
  659. X         (set! mouse:last-y y)))
  660. X
  661. X          (mouse:ERASE
  662. X           (erase-area x y)
  663. X           (set! mouse:last-x ())
  664. X           (set! mouse:last-y ()))
  665. X
  666. X          (mouse:FIDDLE
  667. X           (adjust-wl ($-$ y 256) ($-$ x 128))
  668. X           (set-left-footer-text (strcat "W/L: "
  669. X                         (number->string ($-$ y 256))
  670. X                         "/"
  671. X                         (number->string ($-$ x 128)))))
  672. X
  673. X          (mouse:SELLOI
  674. X           (set-left-footer-text (strcat "LOI: ("
  675. X                         (number->string x)
  676. X                         ", "
  677. X                         (number->string y)
  678. X                         ") = "
  679. X                         (number->string (mouse-set-loi x y mouse:selected)))))
  680. X
  681. X          (mouse:NXTSNK
  682. X           ;; only reachable from clicking on measure button
  683. X           (if (and (nnullp mouse:start-x)
  684. X            (nnullp mouse:last-x))
  685. X             (draw-line mouse:start-x mouse:start-y mouse:last-x mouse:last-y mouse:selected))
  686. X           (set! mouse:last-x ())
  687. X           (set! mouse:last-y ())
  688. X           (set! mouse:mode 'mouse:DRAW)
  689. X           (set-left-footer-text (strcat "Draw: "
  690. X                         (nth mri:buttons mouse:selected))))
  691. X
  692. X      (#t
  693. X       )))))
  694. X
  695. X;; we want the this to be fairly quick
  696. X(set! mouse:handler (bind mouse:handler))
  697. X
  698. X
  699. X
  700. X  
  701. X
  702. CEST_TOUT
  703.     if test `wc -c < jlisp-1.03/lisp/mouse.jl` -ne 4226 ; then
  704.         echo "file jlisp-1.03/lisp/mouse.jl has been corrupted (should be 4226 bytes)"
  705.     fi
  706. fi
  707. if test -f jlisp-1.03/lisp/mrirc.cf.jl -a "$1" != "-c" ; then
  708.     echo "will not overwrite jlisp-1.03/lisp/mrirc.cf.jl"
  709. else
  710.     echo "    x - jlisp-1.03/lisp/mrirc.cf.jl (3805 bytes)"
  711.     sed 's/^X//' > jlisp-1.03/lisp/mrirc.cf.jl << \CEST_TOUT
  712. X
  713. X;;;; Copyright (c) 1994 Jeff Weisberg
  714. X;;;; see the file "License"
  715. X
  716. X;;;; $Id: mrirc.cf.jl,v 1.7 94/08/11 15:50:49 weisberg Exp Locker: weisberg $
  717. X;;;; system wide config file for mritool program
  718. X
  719. X; define-with name default-value type-predicate preprocess-command docstrings
  720. X(define-with mri:across 2 intp () "number of buttons across")
  721. X(define-with mri:buttons                                        ; the button labels
  722. X  '("R Temporal"        "L Temporal"
  723. X    "R White"           "L White"
  724. X    "R Grey"            "L Grey"
  725. X    "R Amygdala"        "L Amygdala"
  726. X    "R Hippocampus"     "L Hippocampus"
  727. X    "R Parahippocampus" "L Parahippocampus"
  728. X    "R Horn"            "L Horn"
  729. X    "R Brain"           "L Brain")
  730. X  listp () "a list of labels for the buttons")
  731. X
  732. X(define-with mri:top-row
  733. X  '(
  734. X    ("File"     (("Patients"      "(show-patient-popup)")
  735. X         ("Next Image"    "(set image next)")
  736. X         ("Prev Image"    "(set image prev)")
  737. X         ("Select Image"  "(show-image-popup)")))
  738. X
  739. X    ("Command"  (("View Modes"    ( ("Image"       "(set mode view)")
  740. X                    ("Segm"        "(set mode segm)")))
  741. X         ("Function"      ( ("Show LUT"    "(show-lut)")
  742. X                    ("New Frame"   "(new-frame)")
  743. X                    ("Analyze"     "(analyze)")))
  744. X         ("Help"          "(help)")
  745. X         ("Refresh"       "(refresh)")
  746. X         ("Visine"        "(progn (visine)(refresh))")
  747. X         ("Snake"         "(progn (show-snake-popup) (show-measure-popup) (show-bounds-popup))")
  748. X         ("Segment"       "(progn (show-segm-popup)  (show-bounds-popup))")
  749. X         ("Quit"          "(quit)")))
  750. X    
  751. X    )
  752. X  listp () "a list describing the buttons and menus along the top of the tool")
  753. X
  754. X
  755. X;;;    locate some important files
  756. X(define-with mri:patdir    (mriname "%PATDIR%")                         stringp mriname "where the mri-scans are")
  757. X(define-with mri:segmdir   (mriname "%SEGMDIR%")                        stringp mriname "where the segm data is kept")
  758. X(define-with mri:etcdir    (mriname "%ETCDIR%")                         stringp mriname "where some goodies are")
  759. X(define-with mri:savedir   (mriname "~/data/save")                      stringp mriname "where to save stuff")
  760. X(define-with mri:savename  "Datafile"                                   stringp ()      "the name of the data file")
  761. X(define-with mri:statefile ".mri-state"                                 stringp ()      "the name of the state file")
  762. X(define-with mri:helpfile  (strcat mri:etcdir "/help.txt")              stringp mriname "the help file")
  763. X(define-with mri:patients  ""                                           stringp mriname "list of patients for this project")
  764. X
  765. X;;; various parameters
  766. X(define-with mri:line-width   2   intp () "the width of lines you draw")
  767. X(define-with mri:line-style   1   intp () "1=solid, 2=dashed, 3=double-dashed")
  768. X(define-with mri:erasor       16  intp () "size of erasor")
  769. X
  770. X(define-with mri:elastic      20  intp () "default snake elasticity")
  771. X(define-with mri:attractive   15  intp () "default snake atractiveness")
  772. X(define-with mri:stiffness    100 intp () "default snake stiffness")
  773. X(define-with mri:3dconstraint 0   intp () "default snake 3D term")
  774. X(define-with mri:similarity   5   intp () "default snake similararity")
  775. X(define-with mri:maxiter      100 intp () "max # of iters when minimizing snake")
  776. X(define-with mri:percent      90  intp () "max # of iters when minimizing snake")
  777. X
  778. X(define-with mri:nlev         6   intp () "defualt number of segm levels")
  779. X
  780. X(define-with mri:window       230 intp () "default window")
  781. X(define-with mri:level        -15 intp () "default level")
  782. X
  783. X(sets! prompt (lambda () (print-stderr "mri(" .lineno ") > ")))
  784. X
  785. X(define-with mri:init-msg
  786. X  (lambda ()
  787. X    (display mri:version) (newline)
  788. X    (display .version)    (newline)
  789. X    (copyright)           (newline) (newline))
  790. X  procedurep () "thunk to display initialization message")
  791. X
  792. CEST_TOUT
  793.     if test `wc -c < jlisp-1.03/lisp/mrirc.cf.jl` -ne 3805 ; then
  794.         echo "file jlisp-1.03/lisp/mrirc.cf.jl has been corrupted (should be 3805 bytes)"
  795.     fi
  796. fi
  797. echo part02 done.
  798. exit 0
  799.  
  800.  
  801.