Artifact
8c48eb6edc54991be3e03e9e7bfac42d13925335:
0000: 3b 3b 20 43 6f 70 79 72 69 67 68 74 20 32 30 30 ;; Copyright 200
0010: 36 2d 32 30 31 31 2c 20 4d 61 74 74 68 65 77 20 6-2011, Matthew
0020: 57 65 6c 6c 61 6e 64 2e 0a 3b 3b 20 0a 3b 3b 20 Welland..;; .;;
0030: 20 54 68 69 73 20 70 72 6f 67 72 61 6d 20 69 73 This program is
0040: 20 6d 61 64 65 20 61 76 61 69 6c 61 62 6c 65 20 made available
0050: 75 6e 64 65 72 20 74 68 65 20 47 4e 55 20 47 50 under the GNU GP
0060: 4c 20 76 65 72 73 69 6f 6e 20 32 2e 30 20 6f 72 L version 2.0 or
0070: 0a 3b 3b 20 20 67 72 65 61 74 65 72 2e 20 53 65 .;; greater. Se
0080: 65 20 74 68 65 20 61 63 63 6f 6d 70 61 6e 79 69 e the accompanyi
0090: 6e 67 20 66 69 6c 65 20 43 4f 50 59 49 4e 47 20 ng file COPYING
00a0: 66 6f 72 20 64 65 74 61 69 6c 73 2e 0a 3b 3b 20 for details..;;
00b0: 0a 3b 3b 20 20 54 68 69 73 20 70 72 6f 67 72 61 .;; This progra
00c0: 6d 20 69 73 20 64 69 73 74 72 69 62 75 74 65 64 m is distributed
00d0: 20 57 49 54 48 4f 55 54 20 41 4e 59 20 57 41 52 WITHOUT ANY WAR
00e0: 52 41 4e 54 59 3b 20 77 69 74 68 6f 75 74 20 65 RANTY; without e
00f0: 76 65 6e 20 74 68 65 0a 3b 3b 20 20 69 6d 70 6c ven the.;; impl
0100: 69 65 64 20 77 61 72 72 61 6e 74 79 20 6f 66 20 ied warranty of
0110: 4d 45 52 43 48 41 4e 54 41 42 49 4c 49 54 59 20 MERCHANTABILITY
0120: 6f 72 20 46 49 54 4e 45 53 53 20 46 4f 52 20 41 or FITNESS FOR A
0130: 20 50 41 52 54 49 43 55 4c 41 52 0a 3b 3b 20 20 PARTICULAR.;;
0140: 50 55 52 50 4f 53 45 2e 0a 0a 3b 3b 20 54 68 69 PURPOSE...;; Thi
0150: 73 20 69 73 20 66 72 6f 6d 20 74 68 65 20 70 65 s is from the pe
0160: 72 6c 20 77 6f 72 6c 64 2c 20 61 20 68 61 73 68 rl world, a hash
0170: 20 6f 66 20 68 61 73 68 65 73 20 69 73 20 61 20 of hashes is a
0180: 73 75 70 65 72 20 65 61 73 79 20 77 61 79 20 74 super easy way t
0190: 6f 20 6b 65 65 70 20 61 20 68 61 6e 64 6c 65 20 o keep a handle
01a0: 6f 6e 0a 3b 3b 20 6c 6f 74 73 20 6f 66 20 64 69 on.;; lots of di
01b0: 73 70 61 72 61 74 65 20 64 61 74 61 0a 3b 3b 0a sparate data.;;.
01c0: 0a 28 63 6f 6e 64 2d 65 78 70 61 6e 64 0a 20 28 .(cond-expand. (
01d0: 63 68 69 63 6b 65 6e 2d 34 0a 20 20 28 75 73 65 chicken-4. (use
01e0: 20 73 68 65 6d 65 20 63 68 69 63 6b 65 6e 29 29 sheme chicken))
01f0: 0a 20 28 63 68 69 63 6b 65 6e 2d 35 0a 20 20 28 . (chicken-5. (
0200: 69 6d 70 6f 72 74 20 73 63 68 65 6d 65 20 63 68 import scheme ch
0210: 69 63 6b 65 6e 2e 62 61 73 65 29 29 29 0a 0a 28 icken.base)))..(
0220: 6d 6f 64 75 6c 65 20 6d 75 74 69 6c 73 0a 20 20 module mutils.
0230: 20 20 2a 0a 0a 28 69 6d 70 6f 72 74 20 73 63 68 *..(import sch
0240: 65 6d 65 29 0a 20 20 20 20 0a 28 63 6f 6e 64 2d eme). .(cond-
0250: 65 78 70 61 6e 64 0a 0a 20 28 63 68 69 63 6b 65 expand.. (chicke
0260: 6e 2d 34 0a 20 20 20 28 69 6d 70 6f 72 74 20 63 n-4. (import c
0270: 68 69 63 6b 65 6e 20 73 63 68 65 6d 65 29 0a 20 hicken scheme).
0280: 20 20 28 75 73 65 20 63 68 69 63 6b 65 6e 29 0a (use chicken).
0290: 20 20 20 28 69 6d 70 6f 72 74 20 70 6f 73 69 78 (import posix
02a0: 0a 09 20 20 64 61 74 61 2d 73 74 72 75 63 74 75 .. data-structu
02b0: 72 65 73 0a 09 20 20 70 6f 72 74 73 0a 09 20 20 res.. ports..
02c0: 65 78 74 72 61 73 29 0a 20 20 20 28 64 65 66 69 extras). (defi
02d0: 6e 65 20 70 73 65 75 64 6f 2d 72 61 6e 64 6f 6d ne pseudo-random
02e0: 2d 69 6e 74 65 67 65 72 20 72 61 6e 64 6f 6d 29 -integer random)
02f0: 0a 20 20 20 28 64 65 66 69 6e 65 20 66 69 6c 65 . (define file
0300: 2d 77 72 69 74 61 62 6c 65 3f 20 66 69 6c 65 2d -writable? file-
0310: 77 72 69 74 65 2d 61 63 63 65 73 73 3f 29 29 0a write-access?)).
0320: 20 0a 20 28 63 68 69 63 6b 65 6e 2d 35 0a 20 20 . (chicken-5.
0330: 28 69 6d 70 6f 72 74 20 73 63 68 65 6d 65 0a 09 (import scheme..
0340: 20 20 63 68 69 63 6b 65 6e 2e 62 61 73 65 0a 09 chicken.base..
0350: 20 20 63 68 69 63 6b 65 6e 2e 66 69 6c 65 0a 09 chicken.file..
0360: 20 20 63 68 69 63 6b 65 6e 2e 70 72 6f 63 65 73 chicken.proces
0370: 73 2d 63 6f 6e 74 65 78 74 0a 09 20 20 63 68 69 s-context.. chi
0380: 63 6b 65 6e 2e 70 72 6f 63 65 73 73 0a 09 20 20 cken.process..
0390: 63 68 69 63 6b 65 6e 2e 70 6f 72 74 0a 09 20 20 chicken.port..
03a0: 63 68 69 63 6b 65 6e 2e 69 6f 0a 09 20 20 73 79 chicken.io.. sy
03b0: 73 74 65 6d 2d 69 6e 66 6f 72 6d 61 74 69 6f 6e stem-information
03c0: 0a 09 20 20 63 68 69 63 6b 65 6e 2e 73 74 72 69 .. chicken.stri
03d0: 6e 67 0a 09 20 20 63 68 69 63 6b 65 6e 2e 74 69 ng.. chicken.ti
03e0: 6d 65 0a 09 20 20 63 68 69 63 6b 65 6e 2e 63 6f me.. chicken.co
03f0: 6e 64 69 74 69 6f 6e 0a 09 20 20 63 68 69 63 6b ndition.. chick
0400: 65 6e 2e 72 61 6e 64 6f 6d 0a 09 20 20 29 29 29 en.random.. )))
0410: 0a 0a 28 69 6d 70 6f 72 74 20 73 72 66 69 2d 31 ..(import srfi-1
0420: 0a 09 3b 3b 20 73 72 66 69 2d 31 33 0a 09 73 72 ..;; srfi-13..sr
0430: 66 69 2d 36 39 0a 09 72 65 67 65 78 0a 09 6d 61 fi-69..regex..ma
0440: 74 63 68 61 62 6c 65 0a 09 73 70 61 72 73 65 2d tchable..sparse-
0450: 76 65 63 74 6f 72 73 0a 09 29 0a 0a 28 64 65 66 vectors..)..(def
0460: 69 6e 65 20 28 6d 75 74 69 6c 73 3a 68 69 65 72 ine (mutils:hier
0470: 68 61 73 68 2d 72 65 66 20 68 68 20 2e 20 6b 65 hash-ref hh . ke
0480: 79 73 29 0a 20 20 28 69 66 20 28 6e 75 6c 6c 3f ys). (if (null?
0490: 20 6b 65 79 73 29 0a 20 20 20 20 20 20 23 66 0a keys). #f.
04a0: 20 20 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 (let loop
04b0: 28 28 68 74 20 20 20 68 68 29 0a 09 09 20 28 6b ((ht hh)... (k
04c0: 65 79 20 20 28 63 61 72 20 6b 65 79 73 29 29 0a ey (car keys)).
04d0: 09 09 20 28 74 61 69 6c 20 28 63 64 72 20 6b 65 .. (tail (cdr ke
04e0: 79 73 29 29 29 0a 09 28 69 66 20 28 6e 75 6c 6c ys)))..(if (null
04f0: 3f 20 74 61 69 6c 29 0a 09 20 20 20 20 28 69 66 ? tail).. (if
0500: 20 28 68 61 73 68 2d 74 61 62 6c 65 3f 20 68 74 (hash-table? ht
0510: 29 0a 09 09 28 68 61 73 68 2d 74 61 62 6c 65 2d )...(hash-table-
0520: 72 65 66 2f 64 65 66 61 75 6c 74 20 68 74 20 6b ref/default ht k
0530: 65 79 20 23 66 29 0a 09 09 23 66 29 0a 09 20 20 ey #f)...#f)..
0540: 20 20 28 69 66 20 28 68 61 73 68 2d 74 61 62 6c (if (hash-tabl
0550: 65 3f 20 68 74 29 0a 09 09 28 6c 6f 6f 70 20 28 e? ht)...(loop (
0560: 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 hash-table-ref/d
0570: 65 66 61 75 6c 74 20 68 74 20 6b 65 79 20 23 66 efault ht key #f
0580: 29 0a 09 09 20 20 20 20 20 20 28 63 61 72 20 74 )... (car t
0590: 61 69 6c 29 0a 09 09 20 20 20 20 20 20 28 63 64 ail)... (cd
05a0: 72 20 74 61 69 6c 29 29 0a 09 09 23 66 29 29 29 r tail))...#f)))
05b0: 29 29 0a 0a 3b 3b 20 57 41 54 43 48 20 54 48 45 ))..;; WATCH THE
05c0: 20 4e 4f 4e 2d 49 4e 54 55 49 54 49 56 45 20 49 NON-INTUITIVE I
05d0: 4e 54 45 52 46 41 43 45 20 48 45 52 45 21 21 21 NTERFACE HERE!!!
05e0: 21 0a 3b 3b 20 76 61 6c 20 63 6f 6d 65 73 20 66 !.;; val comes f
05f0: 69 72 73 74 21 0a 3b 3b 0a 28 64 65 66 69 6e 65 irst!.;;.(define
0600: 20 28 6d 75 74 69 6c 73 3a 68 69 65 72 68 61 73 (mutils:hierhas
0610: 68 2d 73 65 74 21 20 68 68 20 76 61 6c 20 2e 20 h-set! hh val .
0620: 6b 65 79 73 29 0a 20 20 28 69 66 20 28 6e 75 6c keys). (if (nul
0630: 6c 3f 20 6b 65 79 73 29 0a 20 20 20 20 20 20 23 l? keys). #
0640: 66 0a 20 20 20 20 20 20 28 6c 65 74 20 6c 6f 6f f. (let loo
0650: 70 20 28 28 68 74 20 20 20 20 68 68 29 0a 09 09 p ((ht hh)...
0660: 20 28 6b 65 79 20 20 28 63 61 72 20 6b 65 79 73 (key (car keys
0670: 29 29 0a 09 09 20 28 74 61 69 6c 20 28 63 64 72 ))... (tail (cdr
0680: 20 6b 65 79 73 29 29 29 0a 09 28 69 66 20 28 6e keys)))..(if (n
0690: 75 6c 6c 3f 20 74 61 69 6c 29 20 3b 3b 20 6c 61 ull? tail) ;; la
06a0: 73 74 20 6f 6e 65 21 0a 09 20 20 20 20 28 68 61 st one!.. (ha
06b0: 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 68 74 sh-table-set! ht
06c0: 20 6b 65 79 20 76 61 6c 29 0a 09 20 20 20 20 28 key val).. (
06d0: 6c 65 74 20 28 28 6e 68 20 28 68 61 73 68 2d 74 let ((nh (hash-t
06e0: 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 able-ref/default
06f0: 20 68 74 20 6b 65 79 20 23 66 29 29 29 0a 09 20 ht key #f)))..
0700: 20 20 20 20 20 28 69 66 20 28 6e 6f 74 20 6e 68 (if (not nh
0710: 29 28 73 65 74 21 20 6e 68 20 28 6d 61 6b 65 2d )(set! nh (make-
0720: 68 61 73 68 2d 74 61 62 6c 65 29 29 29 0a 09 20 hash-table)))..
0730: 20 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 (hash-table
0740: 2d 73 65 74 21 20 68 74 20 6b 65 79 20 6e 68 29 -set! ht key nh)
0750: 0a 09 20 20 20 20 20 20 28 6c 6f 6f 70 20 6e 68 .. (loop nh
0760: 0a 09 09 20 20 20 20 28 63 61 72 20 74 61 69 6c ... (car tail
0770: 29 0a 09 09 20 20 20 20 28 63 64 72 20 74 61 69 )... (cdr tai
0780: 6c 29 29 29 29 29 29 29 0a 0a 3b 3b 20 6e 69 63 l)))))))..;; nic
0790: 65 20 6c 69 74 74 6c 65 20 72 6f 75 74 69 6e 65 e little routine
07a0: 20 74 6f 20 61 64 64 20 61 6e 20 69 74 65 6d 20 to add an item
07b0: 74 6f 20 61 20 6c 69 73 74 20 69 6e 20 61 20 68 to a list in a h
07c0: 61 73 68 74 61 62 6c 65 20 0a 3b 3b 0a 28 64 65 ashtable .;;.(de
07d0: 66 69 6e 65 20 28 6d 75 74 69 6c 73 3a 68 61 73 fine (mutils:has
07e0: 68 2d 74 61 62 6c 65 2d 61 64 64 2d 74 6f 2d 6c h-table-add-to-l
07f0: 69 73 74 20 68 74 62 6c 20 6b 65 79 20 69 74 65 ist htbl key ite
0800: 6d 29 0a 20 20 28 6c 65 74 20 28 28 6c 20 28 68 m). (let ((l (h
0810: 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 ash-table-ref/de
0820: 66 61 75 6c 74 20 68 74 62 6c 20 6b 65 79 20 23 fault htbl key #
0830: 66 29 29 29 0a 20 20 20 20 28 69 66 20 6c 0a 09 f))). (if l..
0840: 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 (hash-table-set!
0850: 20 68 74 62 6c 20 6b 65 79 20 28 63 6f 6e 73 20 htbl key (cons
0860: 69 74 65 6d 20 6c 29 29 0a 09 28 68 61 73 68 2d item l))..(hash-
0870: 74 61 62 6c 65 2d 73 65 74 21 20 68 74 62 6c 20 table-set! htbl
0880: 6b 65 79 20 28 6c 69 73 74 20 69 74 65 6d 29 29 key (list item))
0890: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 6d 75 )))..(define (mu
08a0: 74 69 6c 73 3a 68 61 73 68 2d 74 61 62 6c 65 2d tils:hash-table-
08b0: 61 70 70 65 6e 64 2d 74 6f 2d 6c 69 73 74 20 68 append-to-list h
08c0: 74 62 6c 20 6b 65 79 20 6c 73 74 29 0a 20 20 28 tbl key lst). (
08d0: 6c 65 74 20 28 28 6c 20 28 68 61 73 68 2d 74 61 let ((l (hash-ta
08e0: 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 ble-ref/default
08f0: 68 74 62 6c 20 6b 65 79 20 23 66 29 29 29 0a 20 htbl key #f))).
0900: 20 20 20 28 69 66 20 6c 0a 09 28 68 61 73 68 2d (if l..(hash-
0910: 74 61 62 6c 65 2d 73 65 74 21 20 68 74 62 6c 20 table-set! htbl
0920: 6b 65 79 20 28 61 70 70 65 6e 64 20 6c 73 74 20 key (append lst
0930: 6c 29 29 0a 20 20 20 20 20 20 20 20 28 68 61 73 l)). (has
0940: 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 68 74 62 h-table-set! htb
0950: 6c 20 6b 65 79 20 6c 73 74 29 29 29 29 0a 0a 3b l key lst))))..;
0960: 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;===============
0970: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0980: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0990: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
09a0: 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 55 74 69 6c 73 =======.;; Utils
09b0: 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;=============
09c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
09d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
09e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
09f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 69 =========..(defi
0a00: 6e 65 20 28 6d 75 74 69 6c 73 3a 66 69 6c 65 2d ne (mutils:file-
0a10: 3e 6c 69 73 74 20 66 6e 61 6d 65 29 0a 20 20 28 >list fname). (
0a20: 6c 65 74 20 28 28 66 68 20 28 6f 70 65 6e 2d 69 let ((fh (open-i
0a30: 6e 70 75 74 2d 66 69 6c 65 20 66 6e 61 6d 65 29 nput-file fname)
0a40: 29 0a 09 28 63 6f 6d 6d 65 6e 74 20 28 72 65 67 )..(comment (reg
0a50: 65 78 70 20 22 5e 5c 5c 73 2a 23 22 29 29 0a 09 exp "^\\s*#"))..
0a60: 28 62 6c 61 6e 6b 20 20 20 28 72 65 67 65 78 70 (blank (regexp
0a70: 20 22 5e 5c 5c 73 2a 24 22 29 29 29 0a 20 20 20 "^\\s*$"))).
0a80: 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 6c 20 20 (let loop ((l
0a90: 20 28 72 65 61 64 2d 6c 69 6e 65 20 66 68 29 29 (read-line fh))
0aa0: 0a 09 20 20 20 20 20 20 20 28 72 65 73 20 27 28 .. (res '(
0ab0: 29 29 29 0a 20 20 20 20 20 20 28 69 66 20 28 65 ))). (if (e
0ac0: 6f 66 2d 6f 62 6a 65 63 74 3f 20 6c 29 0a 09 20 of-object? l)..
0ad0: 20 28 72 65 76 65 72 73 65 20 72 65 73 29 0a 09 (reverse res)..
0ae0: 20 20 28 69 66 20 28 6f 72 20 28 73 74 72 69 6e (if (or (strin
0af0: 67 2d 6d 61 74 63 68 20 63 6f 6d 6d 65 6e 74 20 g-match comment
0b00: 6c 29 0a 09 09 20 20 28 73 74 72 69 6e 67 2d 6d l)... (string-m
0b10: 61 74 63 68 20 62 6c 61 6e 6b 20 6c 29 29 0a 09 atch blank l))..
0b20: 20 20 20 20 20 20 28 6c 6f 6f 70 20 28 72 65 61 (loop (rea
0b30: 64 2d 6c 69 6e 65 20 66 68 29 20 72 65 73 29 0a d-line fh) res).
0b40: 09 20 20 20 20 20 20 28 6c 6f 6f 70 20 28 72 65 . (loop (re
0b50: 61 64 2d 6c 69 6e 65 20 66 68 29 20 28 63 6f 6e ad-line fh) (con
0b60: 73 20 6c 20 72 65 73 29 29 29 29 29 29 29 0a 0a s l res)))))))..
0b70: 3b 3b 20 74 68 69 73 20 69 73 20 61 20 73 69 6d ;; this is a sim
0b80: 70 6c 65 20 74 77 6f 20 64 69 6d 65 6e 73 69 6f ple two dimensio
0b90: 6e 61 6c 20 73 70 61 72 73 65 20 61 72 72 61 79 nal sparse array
0ba0: 0a 0a 3b 3b 20 4f 4e 4c 59 20 54 57 4f 20 44 49 ..;; ONLY TWO DI
0bb0: 4d 45 4e 53 49 4f 4e 53 21 21 21 20 53 45 45 20 MENSIONS!!! SEE
0bc0: 41 52 52 41 59 2d 4c 49 42 20 49 46 20 59 4f 55 ARRAY-LIB IF YOU
0bd0: 52 20 4e 45 45 44 53 20 41 52 45 20 47 52 45 41 R NEEDS ARE GREA
0be0: 54 45 52 21 21 0a 3b 3b 0a 28 64 65 66 69 6e 65 TER!!.;;.(define
0bf0: 20 28 6d 75 74 69 6c 73 3a 6d 61 6b 65 2d 73 70 (mutils:make-sp
0c00: 61 72 73 65 2d 61 72 72 61 79 29 0a 20 20 28 6c arse-array). (l
0c10: 65 74 20 28 28 61 20 28 6d 61 6b 65 2d 73 70 61 et ((a (make-spa
0c20: 72 73 65 2d 76 65 63 74 6f 72 29 29 29 0a 20 20 rse-vector))).
0c30: 20 20 28 73 70 61 72 73 65 2d 76 65 63 74 6f 72 (sparse-vector
0c40: 2d 73 65 74 21 20 61 20 30 20 28 6d 61 6b 65 2d -set! a 0 (make-
0c50: 73 70 61 72 73 65 2d 76 65 63 74 6f 72 29 29 0a sparse-vector)).
0c60: 20 20 20 20 61 29 29 0a 0a 28 64 65 66 69 6e 65 a))..(define
0c70: 20 28 6d 75 74 69 6c 73 3a 73 70 61 72 73 65 2d (mutils:sparse-
0c80: 61 72 72 61 79 3f 20 61 29 0a 20 20 28 61 6e 64 array? a). (and
0c90: 20 28 73 70 61 72 73 65 2d 76 65 63 74 6f 72 3f (sparse-vector?
0ca0: 20 61 29 0a 20 20 20 20 20 20 20 28 73 70 61 72 a). (spar
0cb0: 73 65 2d 76 65 63 74 6f 72 3f 20 28 73 70 61 72 se-vector? (spar
0cc0: 73 65 2d 76 65 63 74 6f 72 2d 72 65 66 20 61 20 se-vector-ref a
0cd0: 30 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 0))))..(define (
0ce0: 6d 75 74 69 6c 73 3a 73 70 61 72 73 65 2d 61 72 mutils:sparse-ar
0cf0: 72 61 79 2d 72 65 66 20 61 20 78 20 79 29 0a 20 ray-ref a x y).
0d00: 20 28 6c 65 74 20 28 28 72 6f 77 20 28 73 70 61 (let ((row (spa
0d10: 72 73 65 2d 76 65 63 74 6f 72 2d 72 65 66 20 61 rse-vector-ref a
0d20: 20 78 29 29 29 0a 20 20 20 20 28 69 66 20 72 6f x))). (if ro
0d30: 77 0a 09 28 73 70 61 72 73 65 2d 76 65 63 74 6f w..(sparse-vecto
0d40: 72 2d 72 65 66 20 72 6f 77 20 79 29 0a 09 23 66 r-ref row y)..#f
0d50: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 6d 75 )))..(define (mu
0d60: 74 69 6c 73 3a 73 70 61 72 73 65 2d 61 72 72 61 tils:sparse-arra
0d70: 79 2d 73 65 74 21 20 61 20 78 20 79 20 76 61 6c y-set! a x y val
0d80: 29 0a 20 20 28 6c 65 74 20 28 28 72 6f 77 20 28 ). (let ((row (
0d90: 73 70 61 72 73 65 2d 76 65 63 74 6f 72 2d 72 65 sparse-vector-re
0da0: 66 20 61 20 78 29 29 29 0a 20 20 20 20 28 69 66 f a x))). (if
0db0: 20 72 6f 77 0a 09 28 73 70 61 72 73 65 2d 76 65 row..(sparse-ve
0dc0: 63 74 6f 72 2d 73 65 74 21 20 72 6f 77 20 79 20 ctor-set! row y
0dd0: 76 61 6c 29 0a 09 28 6c 65 74 20 28 28 6e 65 77 val)..(let ((new
0de0: 2d 72 6f 77 20 28 6d 61 6b 65 2d 73 70 61 72 73 -row (make-spars
0df0: 65 2d 76 65 63 74 6f 72 29 29 29 0a 09 20 20 28 e-vector))).. (
0e00: 73 70 61 72 73 65 2d 76 65 63 74 6f 72 2d 73 65 sparse-vector-se
0e10: 74 21 20 61 20 78 20 6e 65 77 2d 72 6f 77 29 0a t! a x new-row).
0e20: 09 20 20 28 73 70 61 72 73 65 2d 76 65 63 74 6f . (sparse-vecto
0e30: 72 2d 73 65 74 21 20 6e 65 77 2d 72 6f 77 20 79 r-set! new-row y
0e40: 20 76 61 6c 29 29 29 29 29 0a 0a 3b 3b 20 73 6f val)))))..;; so
0e50: 6d 65 20 72 6f 75 74 69 6e 65 73 20 66 6f 72 20 me routines for
0e60: 74 72 65 61 74 69 6e 67 20 61 73 73 6f 63 20 6c treating assoc l
0e70: 69 73 74 73 20 61 20 62 69 74 20 6c 69 6b 65 20 ists a bit like
0e80: 68 61 73 68 20 74 61 62 6c 65 73 0a 0a 28 64 65 hash tables..(de
0e90: 66 69 6e 65 20 28 6d 75 74 69 6c 73 3a 61 73 73 fine (mutils:ass
0ea0: 6f 63 2d 67 65 74 2f 64 65 66 61 75 6c 74 20 61 oc-get/default a
0eb0: 6c 69 73 74 20 6b 65 79 20 64 65 66 61 75 6c 74 list key default
0ec0: 29 0a 20 20 28 6c 65 74 20 28 28 72 65 73 20 28 ). (let ((res (
0ed0: 61 73 73 6f 63 20 6b 65 79 20 61 6c 69 73 74 29 assoc key alist)
0ee0: 29 29 0a 20 20 20 20 28 69 66 20 28 61 6e 64 20 )). (if (and
0ef0: 72 65 73 20 28 6c 69 73 74 3f 20 72 65 73 29 28 res (list? res)(
0f00: 3e 20 28 6c 65 6e 67 74 68 20 72 65 73 29 20 31 > (length res) 1
0f10: 29 29 0a 09 28 63 61 64 72 20 72 65 73 29 0a 09 ))..(cadr res)..
0f20: 64 65 66 61 75 6c 74 29 29 29 0a 0a 28 64 65 66 default)))..(def
0f30: 69 6e 65 20 28 6d 75 74 69 6c 73 3a 61 73 73 6f ine (mutils:asso
0f40: 63 2d 67 65 74 20 61 6c 69 73 74 20 6b 65 79 29 c-get alist key)
0f50: 0a 20 20 28 63 61 64 72 20 28 61 73 73 6f 63 20 . (cadr (assoc
0f60: 6b 65 79 20 61 6c 69 73 74 29 29 29 0a 0a 28 64 key alist)))..(d
0f70: 65 66 69 6e 65 20 28 6d 75 74 69 6c 73 3a 68 69 efine (mutils:hi
0f80: 65 72 2d 6c 69 73 74 3f 20 40 68 69 65 72 6c 69 er-list? @hierli
0f90: 73 74 29 0a 20 20 28 61 6e 64 20 28 6c 69 73 74 st). (and (list
0fa0: 3f 20 40 68 69 65 72 6c 69 73 74 29 0a 20 20 20 ? @hierlist).
0fb0: 20 20 20 20 28 3e 20 28 6c 65 6e 67 74 68 20 40 (> (length @
0fc0: 68 69 65 72 6c 69 73 74 29 20 30 29 0a 20 20 20 hierlist) 0).
0fd0: 20 20 20 20 28 6c 69 73 74 3f 20 28 63 61 72 20 (list? (car
0fe0: 40 68 69 65 72 6c 69 73 74 29 29 0a 20 20 20 20 @hierlist)).
0ff0: 20 20 20 28 3e 20 28 6c 65 6e 67 74 68 20 28 63 (> (length (c
1000: 61 72 20 40 68 69 65 72 6c 69 73 74 29 29 20 31 ar @hierlist)) 1
1010: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 6d 75 )))..(define (mu
1020: 74 69 6c 73 3a 68 69 65 72 2d 6c 69 73 74 2d 67 tils:hier-list-g
1030: 65 74 20 40 68 69 65 72 6c 69 73 74 20 2e 20 40 et @hierlist . @
1040: 70 61 74 68 29 0a 20 20 28 69 66 20 28 6c 69 73 path). (if (lis
1050: 74 3f 20 40 68 69 65 72 6c 69 73 74 29 0a 20 20 t? @hierlist).
1060: 20 20 20 20 28 6c 65 74 2a 20 28 28 24 70 61 74 (let* (($pat
1070: 68 20 28 63 61 72 20 40 70 61 74 68 29 29 0a 09 h (car @path))..
1080: 20 20 20 20 20 28 40 72 65 6d 70 61 74 68 20 28 (@rempath (
1090: 63 64 72 20 40 70 61 74 68 29 29 0a 09 20 20 20 cdr @path))..
10a0: 20 20 28 40 6d 61 74 63 68 20 28 61 73 73 6f 63 (@match (assoc
10b0: 20 24 70 61 74 68 20 40 68 69 65 72 6c 69 73 74 $path @hierlist
10c0: 29 29 29 0a 09 28 69 66 20 40 6d 61 74 63 68 0a )))..(if @match.
10d0: 09 20 20 20 20 28 69 66 20 28 6f 72 20 28 6e 6f . (if (or (no
10e0: 74 20 28 6c 69 73 74 3f 20 40 72 65 6d 70 61 74 t (list? @rempat
10f0: 68 29 29 28 6e 75 6c 6c 3f 20 40 72 65 6d 70 61 h))(null? @rempa
1100: 74 68 29 29 0a 09 09 28 63 61 64 72 20 40 6d 61 th))...(cadr @ma
1110: 74 63 68 29 0a 09 09 28 61 70 70 6c 79 20 6d 75 tch)...(apply mu
1120: 74 69 6c 73 3a 68 69 65 72 2d 6c 69 73 74 2d 67 tils:hier-list-g
1130: 65 74 20 28 63 61 64 72 20 40 6d 61 74 63 68 29 et (cadr @match)
1140: 20 40 72 65 6d 70 61 74 68 29 29 0a 09 20 20 20 @rempath))..
1150: 20 23 66 29 29 0a 20 20 20 20 20 20 23 66 29 29 #f)). #f))
1160: 0a 0a 28 64 65 66 69 6e 65 20 28 6d 75 74 69 6c ..(define (mutil
1170: 73 3a 68 69 65 72 2d 6c 69 73 74 2d 70 75 74 21 s:hier-list-put!
1180: 20 40 68 69 65 72 6c 69 73 74 20 2e 20 40 70 61 @hierlist . @pa
1190: 74 68 29 0a 20 20 28 6c 65 74 2a 20 28 28 24 70 th). (let* (($p
11a0: 61 74 68 20 28 63 61 72 20 40 70 61 74 68 29 29 ath (car @path))
11b0: 0a 09 20 28 40 72 65 6d 70 61 74 68 20 28 63 64 .. (@rempath (cd
11c0: 72 20 40 70 61 74 68 29 29 0a 09 20 28 24 76 61 r @path)).. ($va
11d0: 6c 75 65 20 20 20 28 63 61 64 72 20 40 70 61 74 lue (cadr @pat
11e0: 68 29 29 0a 09 20 28 40 6d 61 74 63 68 20 28 61 h)).. (@match (a
11f0: 73 73 6f 63 20 24 70 61 74 68 20 40 68 69 65 72 ssoc $path @hier
1200: 6c 69 73 74 29 29 0a 09 20 28 40 72 65 6d 68 69 list)).. (@remhi
1210: 65 72 6c 69 73 74 20 28 72 65 6d 6f 76 65 20 28 erlist (remove (
1220: 6c 61 6d 62 64 61 20 28 61 29 0a 20 20 20 20 20 lambda (a).
1230: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1240: 20 20 20 20 20 20 20 20 20 20 20 20 28 65 71 75 (equ
1250: 61 6c 3f 20 61 20 40 6d 61 74 63 68 29 29 0a 20 al? a @match)).
1260: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1270: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 40 68 @h
1280: 69 65 72 6c 69 73 74 29 29 0a 20 20 20 20 20 20 ierlist)).
1290: 20 20 20 28 40 6f 6c 64 2d 70 61 69 72 20 28 6c (@old-pair (l
12a0: 65 74 20 28 28 24 76 61 6c 75 65 20 28 6d 75 74 et (($value (mut
12b0: 69 6c 73 3a 68 69 65 72 2d 6c 69 73 74 2d 67 65 ils:hier-list-ge
12c0: 74 20 40 68 69 65 72 6c 69 73 74 20 24 70 61 74 t @hierlist $pat
12d0: 68 29 29 29 20 28 69 66 20 24 76 61 6c 75 65 20 h))) (if $value
12e0: 24 76 61 6c 75 65 20 27 28 29 29 29 29 0a 09 20 $value '())))..
12f0: 28 40 6e 65 77 2d 70 61 69 72 20 28 6c 69 73 74 (@new-pair (list
1300: 20 24 70 61 74 68 20 28 69 66 20 28 65 71 3f 20 $path (if (eq?
1310: 28 6c 65 6e 67 74 68 20 40 72 65 6d 70 61 74 68 (length @rempath
1320: 29 20 31 29 20 0a 09 09 09 09 20 20 20 20 28 63 ) 1) ..... (c
1330: 61 72 20 40 72 65 6d 70 61 74 68 29 0a 09 09 09 ar @rempath)....
1340: 09 20 20 20 20 28 61 70 70 6c 79 20 6d 75 74 69 . (apply muti
1350: 6c 73 3a 68 69 65 72 2d 6c 69 73 74 2d 70 75 74 ls:hier-list-put
1360: 21 20 40 6f 6c 64 2d 70 61 69 72 20 40 72 65 6d ! @old-pair @rem
1370: 70 61 74 68 29 29 29 29 29 0a 20 20 20 20 28 63 path))))). (c
1380: 6f 6e 73 20 40 6e 65 77 2d 70 61 69 72 20 40 72 ons @new-pair @r
1390: 65 6d 68 69 65 72 6c 69 73 74 29 29 29 0a 0a 28 emhierlist)))..(
13a0: 64 65 66 69 6e 65 20 28 6d 75 74 69 6c 73 3a 68 define (mutils:h
13b0: 69 65 72 2d 6c 69 73 74 2d 72 65 6d 6f 76 65 21 ier-list-remove!
13c0: 20 40 68 69 65 72 6c 69 73 74 20 2e 20 40 70 61 @hierlist . @pa
13d0: 74 68 29 0a 20 20 28 6c 65 74 20 28 28 24 70 61 th). (let (($pa
13e0: 74 68 20 28 63 61 72 20 40 70 61 74 68 29 29 29 th (car @path)))
13f0: 0a 20 20 20 20 28 69 66 20 28 65 71 3f 20 28 6c . (if (eq? (l
1400: 65 6e 67 74 68 20 40 70 61 74 68 29 20 31 29 0a ength @path) 1).
1410: 09 28 72 65 6d 6f 76 65 20 28 6c 61 6d 62 64 61 .(remove (lambda
1420: 20 28 61 29 0a 20 20 20 20 20 20 20 20 20 20 20 (a).
1430: 20 20 20 20 20 20 20 28 65 71 75 61 6c 3f 20 61 (equal? a
1440: 20 28 61 73 73 6f 63 20 24 70 61 74 68 20 40 68 (assoc $path @h
1450: 69 65 72 6c 69 73 74 29 29 29 0a 20 20 20 20 20 ierlist))).
1460: 20 20 20 20 20 20 20 20 20 20 20 40 68 69 65 72 @hier
1470: 6c 69 73 74 29 0a 09 28 6c 65 74 2a 20 28 28 40 list)..(let* ((@
1480: 72 65 6d 70 61 74 68 20 28 63 64 72 20 40 70 61 rempath (cdr @pa
1490: 74 68 29 29 0a 09 20 20 20 20 20 20 20 28 40 6d th)).. (@m
14a0: 61 74 63 68 20 28 61 73 73 6f 63 20 24 70 61 74 atch (assoc $pat
14b0: 68 20 40 68 69 65 72 6c 69 73 74 29 29 0a 09 20 h @hierlist))..
14c0: 20 20 20 20 20 20 28 40 72 65 6d 68 69 65 72 6c (@remhierl
14d0: 69 73 74 20 28 72 65 6d 6f 76 65 20 28 6c 61 6d ist (remove (lam
14e0: 62 64 61 20 28 61 29 20 0a 20 20 20 20 20 20 20 bda (a) .
14f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1500: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1510: 28 65 71 75 61 6c 3f 20 40 6d 61 74 63 68 20 61 (equal? @match a
1520: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
1530: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1540: 20 20 20 20 20 20 20 20 40 68 69 65 72 6c 69 73 @hierlis
1550: 74 29 29 0a 09 20 20 20 20 20 20 20 28 40 6f 6c t)).. (@ol
1560: 64 2d 70 61 69 72 20 28 6c 65 74 20 28 28 24 76 d-pair (let (($v
1570: 61 6c 75 65 20 28 6d 75 74 69 6c 73 3a 68 69 65 alue (mutils:hie
1580: 72 2d 6c 69 73 74 2d 67 65 74 20 40 68 69 65 72 r-list-get @hier
1590: 6c 69 73 74 20 24 70 61 74 68 29 29 29 20 28 69 list $path))) (i
15a0: 66 20 24 76 61 6c 75 65 20 24 76 61 6c 75 65 20 f $value $value
15b0: 27 28 29 29 29 29 0a 09 20 20 20 20 20 20 20 28 '()))).. (
15c0: 40 6e 65 77 2d 70 61 69 72 20 28 6c 69 73 74 20 @new-pair (list
15d0: 24 70 61 74 68 20 28 61 70 70 6c 79 20 6d 75 74 $path (apply mut
15e0: 69 6c 73 3a 68 69 65 72 2d 6c 69 73 74 2d 72 65 ils:hier-list-re
15f0: 6d 6f 76 65 21 20 40 6f 6c 64 2d 70 61 69 72 20 move! @old-pair
1600: 40 72 65 6d 70 61 74 68 29 29 29 29 0a 09 20 20 @rempath))))..
1610: 28 63 6f 6e 73 20 40 6e 65 77 2d 70 61 69 72 20 (cons @new-pair
1620: 40 72 65 6d 68 69 65 72 6c 69 73 74 29 29 29 29 @remhierlist))))
1630: 29 0a 0a 28 64 65 66 69 6e 65 20 28 6d 75 74 69 )..(define (muti
1640: 6c 73 3a 6b 65 79 73 20 40 68 69 65 72 6c 69 73 ls:keys @hierlis
1650: 74 20 2e 20 40 70 61 74 68 29 0a 20 20 28 6d 61 t . @path). (ma
1660: 70 20 28 6c 61 6d 62 64 61 20 28 40 6c 29 0a 09 p (lambda (@l)..
1670: 20 28 69 66 20 28 61 6e 64 20 28 6c 69 73 74 3f (if (and (list?
1680: 20 40 6c 29 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 @l)(not (null?
1690: 40 6c 29 29 29 20 0a 09 20 20 20 20 20 28 63 61 @l))) .. (ca
16a0: 72 20 40 6c 29 29 29 20 0a 20 20 20 20 20 20 20 r @l))) .
16b0: 28 69 66 20 28 6e 75 6c 6c 3f 20 40 70 61 74 68 (if (null? @path
16c0: 29 20 40 68 69 65 72 6c 69 73 74 0a 09 20 20 20 ) @hierlist..
16d0: 28 61 70 70 6c 79 20 6d 75 74 69 6c 73 3a 68 69 (apply mutils:hi
16e0: 65 72 2d 6c 69 73 74 2d 67 65 74 20 40 68 69 65 er-list-get @hie
16f0: 72 6c 69 73 74 20 40 70 61 74 68 29 29 29 29 0a rlist @path)))).
1700: 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;=============
1710: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1720: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1730: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1740: 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 4f 74 68 =========.;; Oth
1750: 65 72 20 75 74 69 6c 73 0a 3b 3b 3d 3d 3d 3d 3d er utils.;;=====
1760: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1770: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1780: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1790: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
17a0: 3d 0a 0a 28 64 65 66 69 6e 65 20 28 63 68 65 63 =..(define (chec
17b0: 6b 2d 77 72 69 74 65 2d 63 72 65 61 74 65 20 66 k-write-create f
17c0: 70 61 74 68 29 0a 20 20 28 61 6e 64 20 28 66 69 path). (and (fi
17d0: 6c 65 2d 77 72 69 74 61 62 6c 65 3f 20 66 70 61 le-writable? fpa
17e0: 74 68 29 0a 20 20 20 20 20 20 20 28 6c 65 74 20 th). (let
17f0: 28 28 66 6e 61 6d 65 20 28 63 6f 6e 63 20 66 70 ((fname (conc fp
1800: 61 74 68 20 22 2f 2e 6a 75 6e 6b 2d 22 20 28 63 ath "/.junk-" (c
1810: 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 20 urrent-seconds)
1820: 22 2d 22 20 28 70 73 65 75 64 6f 2d 72 61 6e 64 "-" (pseudo-rand
1830: 6f 6d 2d 69 6e 74 65 67 65 72 20 31 30 30 30 30 om-integer 10000
1840: 29 29 29 29 0a 09 20 3b 3b 28 70 72 69 6e 74 20 )))).. ;;(print
1850: 22 74 72 79 69 6e 67 20 74 6f 20 63 72 65 61 74 "trying to creat
1860: 65 2f 72 65 6d 6f 76 65 20 22 20 66 6e 61 6d 65 e/remove " fname
1870: 29 0a 09 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 ).. (handle-exce
1880: 70 74 69 6f 6e 73 0a 09 20 20 65 78 6e 0a 09 20 ptions.. exn..
1890: 20 23 66 0a 09 20 20 28 62 65 67 69 6e 0a 09 20 #f.. (begin..
18a0: 20 20 20 28 77 69 74 68 2d 6f 75 74 70 75 74 2d (with-output-
18b0: 74 6f 2d 66 69 6c 65 20 66 6e 61 6d 65 0a 09 20 to-file fname..
18c0: 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 29 0a (lambda ().
18d0: 09 09 28 70 72 69 6e 74 20 22 59 6f 75 20 63 61 ..(print "You ca
18e0: 6e 20 64 65 6c 65 74 65 20 74 68 69 73 20 66 69 n delete this fi
18f0: 6c 65 22 29 29 29 0a 09 20 20 20 20 28 64 65 6c le"))).. (del
1900: 65 74 65 2d 66 69 6c 65 20 66 6e 61 6d 65 29 0a ete-file fname).
1910: 09 20 20 20 20 23 74 29 29 29 29 29 0a 0a 28 64 . #t)))))..(d
1920: 65 66 69 6e 65 20 28 72 75 6e 2d 61 6e 64 2d 72 efine (run-and-r
1930: 65 74 75 72 6e 2d 6f 75 74 70 75 74 20 63 6d 64 eturn-output cmd
1940: 20 2e 20 70 61 72 61 6d 73 29 0a 20 20 28 6c 65 . params). (le
1950: 74 2d 76 61 6c 75 65 73 20 28 28 28 69 6e 70 20 t-values (((inp
1960: 6f 75 70 20 70 69 64 29 0a 09 09 28 70 72 6f 63 oup pid)...(proc
1970: 65 73 73 20 63 6d 64 20 70 61 72 61 6d 73 29 29 ess cmd params))
1980: 29 0a 20 20 20 20 28 6c 65 74 20 28 28 72 65 73 ). (let ((res
1990: 20 28 77 69 74 68 2d 69 6e 70 75 74 2d 66 72 6f (with-input-fro
19a0: 6d 2d 70 6f 72 74 20 69 6e 70 20 72 65 61 64 2d m-port inp read-
19b0: 6c 69 6e 65 73 29 29 29 0a 20 20 20 20 20 20 28 lines))). (
19c0: 6c 65 74 2d 76 61 6c 75 65 73 20 28 28 28 70 69 let-values (((pi
19d0: 64 72 65 73 20 73 74 61 74 75 73 20 65 73 74 61 dres status esta
19e0: 74 75 73 29 0a 09 09 20 20 20 20 28 70 72 6f 63 tus)... (proc
19f0: 65 73 73 2d 77 61 69 74 20 70 69 64 29 29 29 0a ess-wait pid))).
1a00: 09 28 61 6e 64 20 73 74 61 74 75 73 20 28 65 71 .(and status (eq
1a10: 3f 20 65 73 74 61 74 75 73 20 30 29 20 72 65 73 ? estatus 0) res
1a20: 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 )))))..(define (
1a30: 63 6f 6e 66 69 72 6d 2d 73 73 68 2d 61 63 63 65 confirm-ssh-acce
1a40: 73 73 2d 74 6f 2d 68 6f 73 74 20 68 6f 73 74 6e ss-to-host hostn
1a50: 61 6d 65 29 0a 20 20 28 72 75 6e 2d 61 6e 64 2d ame). (run-and-
1a60: 72 65 74 75 72 6e 2d 6f 75 74 70 75 74 20 22 73 return-output "s
1a70: 73 68 22 20 68 6f 73 74 6e 61 6d 65 20 22 75 70 sh" hostname "up
1a80: 74 69 6d 65 22 29 29 0a 0a 28 64 65 66 69 6e 65 time"))..(define
1a90: 20 28 63 68 65 63 6b 2d 64 69 73 70 6c 61 79 20 (check-display
1aa0: 64 73 70 29 0a 20 20 28 72 75 6e 2d 61 6e 64 2d dsp). (run-and-
1ab0: 72 65 74 75 72 6e 2d 6f 75 74 70 75 74 20 22 78 return-output "x
1ac0: 64 70 79 69 6e 66 6f 22 20 22 2d 64 69 73 70 6c dpyinfo" "-displ
1ad0: 61 79 22 20 64 73 70 29 29 0a 0a 23 3b 28 64 65 ay" dsp))..#;(de
1ae0: 66 69 6e 65 20 28 63 68 65 63 6b 2d 64 69 73 70 fine (check-disp
1af0: 6c 61 79 20 64 73 70 29 0a 20 20 28 6c 65 74 2d lay dsp). (let-
1b00: 76 61 6c 75 65 73 20 28 28 28 69 6e 70 20 6f 75 values (((inp ou
1b10: 70 20 70 69 64 29 0a 09 09 28 70 72 6f 63 65 73 p pid)...(proces
1b20: 73 20 22 78 64 70 79 69 6e 66 6f 22 20 60 28 22 s "xdpyinfo" `("
1b30: 2d 64 69 73 70 6c 61 79 22 20 2c 64 73 70 29 29 -display" ,dsp))
1b40: 29 29 0a 20 20 20 20 28 6c 65 74 20 28 28 72 65 )). (let ((re
1b50: 73 20 28 77 69 74 68 2d 69 6e 70 75 74 2d 66 72 s (with-input-fr
1b60: 6f 6d 2d 70 6f 72 74 20 69 6e 70 20 72 65 61 64 om-port inp read
1b70: 2d 6c 69 6e 65 73 29 29 29 0a 20 20 20 20 20 20 -lines))).
1b80: 28 6c 65 74 2d 76 61 6c 75 65 73 20 28 28 28 70 (let-values (((p
1b90: 69 64 72 65 73 20 73 74 61 74 75 73 20 65 73 74 idres status est
1ba0: 61 74 75 73 29 0a 09 09 20 20 20 20 28 70 72 6f atus)... (pro
1bb0: 63 65 73 73 2d 77 61 69 74 20 70 69 64 29 29 29 cess-wait pid)))
1bc0: 0a 09 28 61 6e 64 20 73 74 61 74 75 73 20 28 65 ..(and status (e
1bd0: 71 3f 20 65 73 74 61 74 75 73 20 30 29 20 72 65 q? estatus 0) re
1be0: 73 29 29 29 29 29 0a 0a 3b 3b 20 64 6f 20 73 6f s)))))..;; do so
1bf0: 6d 65 20 73 61 6e 69 74 79 20 63 68 65 63 6b 73 me sanity checks
1c00: 20 6f 6e 20 74 68 65 20 73 79 73 74 65 6d 0a 3b on the system.;
1c10: 3b 0a 28 64 65 66 69 6e 65 20 28 6d 75 74 69 6c ;.(define (mutil
1c20: 73 3a 73 79 73 63 68 65 63 6b 20 63 6f 6d 6d 6f s:syscheck commo
1c30: 6e 3a 72 61 77 2d 67 65 74 2d 72 65 6d 6f 74 65 n:raw-get-remote
1c40: 2d 68 6f 73 74 2d 6c 6f 61 64 0a 09 09 09 20 73 -host-load.... s
1c50: 65 72 76 65 72 3a 67 65 74 2d 62 65 73 74 2d 67 erver:get-best-g
1c60: 75 65 73 73 2d 61 64 64 72 65 73 73 0a 09 09 09 uess-address....
1c70: 20 72 65 61 64 2d 63 6f 6e 66 69 67 29 0a 20 20 read-config).
1c80: 3b 3b 20 63 75 72 72 65 6e 74 20 64 69 72 20 77 ;; current dir w
1c90: 72 69 74 65 61 62 6c 65 20 61 6e 64 20 64 6f 20 riteable and do
1ca0: 6d 65 67 61 74 65 73 74 2e 63 6f 6e 66 69 67 2c megatest.config,
1cb0: 20 72 75 6e 63 6f 6e 66 69 67 73 2e 63 6f 6e 66 runconfigs.conf
1cc0: 69 67 20 66 69 6c 65 73 20 65 78 69 73 74 2f 72 ig files exist/r
1cd0: 65 61 64 61 62 6c 65 0a 20 20 28 70 72 69 6e 74 eadable. (print
1ce0: 20 22 43 75 72 72 65 6e 74 20 64 69 72 65 63 74 "Current direct
1cf0: 6f 72 79 20 22 20 28 63 75 72 72 65 6e 74 2d 64 ory " (current-d
1d00: 69 72 65 63 74 6f 72 79 29 20 22 20 77 72 69 74 irectory) " writ
1d10: 65 61 62 6c 65 3a 20 22 20 0a 09 20 28 69 66 20 eable: " .. (if
1d20: 28 63 68 65 63 6b 2d 77 72 69 74 65 2d 63 72 65 (check-write-cre
1d30: 61 74 65 20 22 2e 22 29 20 22 79 65 73 22 20 22 ate ".") "yes" "
1d40: 4e 4f 22 29 29 0a 20 20 3b 3b 20 68 6f 6d 65 20 NO")). ;; home
1d50: 64 69 72 20 77 72 69 74 65 61 62 6c 65 0a 20 20 dir writeable.
1d60: 28 70 72 69 6e 74 20 22 48 6f 6d 65 20 64 69 72 (print "Home dir
1d70: 65 63 74 6f 72 79 20 22 20 28 67 65 74 2d 65 6e ectory " (get-en
1d80: 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 62 vironment-variab
1d90: 6c 65 20 22 48 4f 4d 45 22 29 20 22 20 77 72 69 le "HOME") " wri
1da0: 74 65 61 62 6c 65 3a 20 22 0a 09 20 28 69 66 20 teable: ".. (if
1db0: 28 63 68 65 63 6b 2d 77 72 69 74 65 2d 63 72 65 (check-write-cre
1dc0: 61 74 65 20 28 67 65 74 2d 65 6e 76 69 72 6f 6e ate (get-environ
1dd0: 6d 65 6e 74 2d 76 61 72 69 61 62 6c 65 20 22 48 ment-variable "H
1de0: 4f 4d 45 22 29 29 20 22 79 65 73 22 20 22 4e 4f OME")) "yes" "NO
1df0: 22 29 29 0a 20 20 3b 3b 20 2f 74 6d 70 20 77 72 ")). ;; /tmp wr
1e00: 69 74 65 61 62 6c 65 0a 20 20 28 70 72 69 6e 74 iteable. (print
1e10: 20 22 2f 74 6d 70 20 64 69 72 65 63 74 6f 72 79 "/tmp directory
1e20: 20 77 72 69 74 65 61 62 6c 65 3a 20 22 20 28 69 writeable: " (i
1e30: 66 20 28 63 68 65 63 6b 2d 77 72 69 74 65 2d 63 f (check-write-c
1e40: 72 65 61 74 65 20 22 2f 74 6d 70 22 29 20 22 79 reate "/tmp") "y
1e50: 65 73 22 20 22 4e 4f 22 29 29 0a 20 20 3b 3b 20 es" "NO")). ;;
1e60: 6c 6f 61 64 20 63 6f 6e 66 69 67 73 0a 20 20 28 load configs. (
1e70: 70 72 69 6e 74 20 22 24 44 49 53 50 4c 41 59 20 print "$DISPLAY
1e80: 73 65 74 3a 20 22 20 28 69 66 20 28 67 65 74 2d set: " (if (get-
1e90: 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 environment-vari
1ea0: 61 62 6c 65 20 22 44 49 53 50 4c 41 59 22 29 0a able "DISPLAY").
1eb0: 09 09 09 20 20 20 20 20 20 28 63 6f 6e 63 20 20 ... (conc
1ec0: 28 67 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 (get-environment
1ed0: 2d 76 61 72 69 61 62 6c 65 20 22 44 49 53 50 4c -variable "DISPL
1ee0: 41 59 22 29 20 22 20 79 65 73 22 29 0a 09 09 09 AY") " yes")....
1ef0: 20 20 20 20 20 20 22 4e 4f 22 29 29 0a 0a 20 20 "NO"))..
1f00: 28 70 72 69 6e 74 20 22 24 44 49 53 50 4c 41 59 (print "$DISPLAY
1f10: 20 61 63 63 65 73 73 69 62 6c 65 3f 20 22 0a 09 accessible? "..
1f20: 20 20 3b 3b 20 28 65 71 3f 20 28 73 79 73 74 65 ;; (eq? (syste
1f30: 6d 20 22 78 64 70 79 69 6e 66 6f 20 2d 64 69 73 m "xdpyinfo -dis
1f40: 70 6c 61 79 20 24 44 49 53 50 4c 41 59 20 26 3e play $DISPLAY &>
1f50: 2f 64 65 76 2f 6e 75 6c 6c 22 29 20 30 29 0a 09 /dev/null") 0)..
1f60: 20 28 69 66 20 28 63 68 65 63 6b 2d 64 69 73 70 (if (check-disp
1f70: 6c 61 79 20 28 67 65 74 2d 65 6e 76 69 72 6f 6e lay (get-environ
1f80: 6d 65 6e 74 2d 76 61 72 69 61 62 6c 65 20 22 44 ment-variable "D
1f90: 49 53 50 4c 41 59 22 29 29 0a 09 20 20 20 20 20 ISPLAY"))..
1fa0: 22 79 65 73 22 20 22 4e 4f 22 29 29 0a 0a 20 20 "yes" "NO"))..
1fb0: 28 70 72 69 6e 74 20 22 50 61 73 73 77 6f 72 64 (print "Password
1fc0: 2d 6c 65 73 73 20 73 73 68 20 61 63 63 65 73 73 -less ssh access
1fd0: 20 74 6f 20 6c 6f 63 61 6c 68 6f 73 74 3a 20 22 to localhost: "
1fe0: 0a 09 20 28 69 66 20 20 28 63 6f 6e 66 69 72 6d .. (if (confirm
1ff0: 2d 73 73 68 2d 61 63 63 65 73 73 2d 74 6f 2d 68 -ssh-access-to-h
2000: 6f 73 74 20 22 6c 6f 63 61 6c 68 6f 73 74 22 29 ost "localhost")
2010: 0a 09 20 20 20 20 20 20 22 79 65 73 22 0a 09 20 .. "yes"..
2020: 20 20 20 20 20 22 4e 4f 22 29 29 0a 0a 20 20 3b "NO")).. ;
2030: 3b 20 69 66 20 49 27 6d 20 69 6e 20 61 20 4d 65 ; if I'm in a Me
2040: 67 61 74 65 73 74 20 61 72 65 61 20 64 6f 20 73 gatest area do s
2050: 6f 6d 65 20 63 68 65 63 6b 73 0a 20 20 28 70 72 ome checks. (pr
2060: 69 6e 74 20 22 48 61 76 65 20 6d 65 67 61 74 65 int "Have megate
2070: 73 74 2e 63 6f 6e 66 69 67 3a 20 22 0a 09 20 28 st.config: ".. (
2080: 69 66 20 28 66 69 6c 65 2d 65 78 69 73 74 73 3f if (file-exists?
2090: 20 22 6d 65 67 61 74 65 73 74 2e 63 6f 6e 66 69 "megatest.confi
20a0: 67 22 29 0a 09 20 20 20 20 20 22 79 65 73 22 0a g").. "yes".
20b0: 09 20 20 20 20 20 22 4e 4f 22 29 29 0a 0a 20 20 . "NO"))..
20c0: 28 70 72 69 6e 74 20 22 48 61 76 65 20 72 75 6e (print "Have run
20d0: 63 6f 6e 66 69 67 73 2e 63 6f 6e 66 69 67 3a 20 configs.config:
20e0: 22 0a 09 20 28 69 66 20 28 66 69 6c 65 2d 65 78 ".. (if (file-ex
20f0: 69 73 74 73 3f 20 22 72 75 6e 63 6f 6e 66 69 67 ists? "runconfig
2100: 73 2e 63 6f 6e 66 69 67 22 29 0a 09 20 20 20 20 s.config")..
2110: 20 22 79 65 73 22 0a 09 20 20 20 20 20 22 4e 4f "yes".. "NO
2120: 22 29 29 0a 0a 20 20 28 69 66 20 28 66 69 6c 65 ")).. (if (file
2130: 2d 65 78 69 73 74 73 3f 20 22 2e 68 6f 6d 65 68 -exists? ".homeh
2140: 6f 73 74 22 29 0a 20 20 20 20 20 20 28 6c 65 74 ost"). (let
2150: 2a 20 28 28 68 6f 6d 65 68 6f 73 74 20 28 77 69 * ((homehost (wi
2160: 74 68 2d 69 6e 70 75 74 2d 66 72 6f 6d 2d 66 69 th-input-from-fi
2170: 6c 65 20 22 2e 68 6f 6d 65 68 6f 73 74 22 0a 09 le ".homehost"..
2180: 09 09 20 72 65 61 64 2d 6c 69 6e 65 29 29 0a 09 .. read-line))..
2190: 20 20 20 20 20 28 63 75 72 72 68 6f 73 74 20 28 (currhost (
21a0: 67 65 74 2d 68 6f 73 74 2d 6e 61 6d 65 29 29 0a get-host-name)).
21b0: 09 20 20 20 20 20 28 62 65 73 74 61 64 72 73 20 . (bestadrs
21c0: 28 73 65 72 76 65 72 3a 67 65 74 2d 62 65 73 74 (server:get-best
21d0: 2d 67 75 65 73 73 2d 61 64 64 72 65 73 73 20 63 -guess-address c
21e0: 75 72 72 68 6f 73 74 29 29 29 0a 09 28 70 72 69 urrhost)))..(pri
21f0: 6e 74 20 22 48 61 76 65 20 2e 68 6f 6d 65 68 6f nt "Have .homeho
2200: 73 74 20 61 6e 64 20 69 74 20 69 73 20 74 68 65 st and it is the
2210: 20 6c 6f 63 61 6c 68 6f 73 74 3a 20 22 0a 09 20 localhost: "..
2220: 20 20 20 20 20 20 28 69 66 20 28 65 71 75 61 6c (if (equal
2230: 3f 20 68 6f 6d 65 68 6f 73 74 20 62 65 73 74 61 ? homehost besta
2240: 64 72 73 29 0a 09 09 20 20 20 22 79 65 73 22 0a drs)... "yes".
2250: 09 09 20 20 20 28 63 6f 6e 63 20 22 2e 68 6f 6d .. (conc ".hom
2260: 65 68 6f 73 74 3d 22 20 68 6f 6d 65 68 6f 73 74 ehost=" homehost
2270: 20 22 2c 20 6c 6f 63 61 6c 68 6f 73 74 3d 22 20 ", localhost="
2280: 62 65 73 74 61 64 72 73 20 22 2c 20 4e 4f 22 29 bestadrs ", NO")
2290: 29 29 0a 09 28 70 72 69 6e 74 20 22 48 61 76 65 ))..(print "Have
22a0: 20 2e 68 6f 6d 65 68 6f 73 74 20 61 6e 64 20 69 .homehost and i
22b0: 74 20 69 73 20 72 65 61 63 68 61 62 6c 65 20 76 t is reachable v
22c0: 69 61 20 73 73 68 3a 20 22 0a 09 20 20 20 20 20 ia ssh: "..
22d0: 20 20 28 69 66 20 28 63 6f 6e 66 69 72 6d 2d 73 (if (confirm-s
22e0: 73 68 2d 61 63 63 65 73 73 2d 74 6f 2d 68 6f 73 sh-access-to-hos
22f0: 74 20 68 6f 6d 65 68 6f 73 74 29 0a 09 09 20 20 t homehost)...
2300: 20 22 79 65 73 22 0a 09 09 20 20 20 22 4e 4f 22 "yes"... "NO"
2310: 29 29 0a 09 29 29 0a 0a 20 20 28 69 66 20 28 66 ))..)).. (if (f
2320: 69 6c 65 2d 65 78 69 73 74 73 3f 20 22 6d 65 67 ile-exists? "meg
2330: 61 74 65 73 74 2e 63 6f 6e 66 69 67 22 29 0a 20 atest.config").
2340: 20 20 20 20 20 28 6c 65 74 2a 20 28 28 63 64 61 (let* ((cda
2350: 74 20 28 72 65 61 64 2d 63 6f 6e 66 69 67 20 22 t (read-config "
2360: 6d 65 67 61 74 65 73 74 2e 63 6f 6e 66 69 67 22 megatest.config"
2370: 20 23 66 20 23 66 29 29 29 0a 09 28 70 72 69 6e #f #f)))..(prin
2380: 74 20 22 48 61 76 65 20 5b 64 69 73 6b 73 5d 20 t "Have [disks]
2390: 73 65 63 74 69 6f 6e 3a 20 22 0a 09 20 20 20 20 section: "..
23a0: 20 20 20 28 69 66 20 28 68 61 73 68 2d 74 61 62 (if (hash-tab
23b0: 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 63 le-ref/default c
23c0: 64 61 74 20 22 64 69 73 6b 73 22 20 23 66 29 0a dat "disks" #f).
23d0: 09 09 20 20 20 28 63 6f 6e 63 20 28 68 61 73 68 .. (conc (hash
23e0: 2d 74 61 62 6c 65 2d 72 65 66 20 63 64 61 74 20 -table-ref cdat
23f0: 22 64 69 73 6b 73 22 29 20 22 20 79 65 73 22 29 "disks") " yes")
2400: 0a 09 09 20 20 20 22 4e 4f 22 29 29 0a 09 28 66 ... "NO"))..(f
2410: 6f 72 2d 65 61 63 68 0a 09 20 28 6c 61 6d 62 64 or-each.. (lambd
2420: 61 20 28 65 6e 74 72 79 29 0a 09 20 20 20 28 6d a (entry).. (m
2430: 61 74 63 68 0a 09 20 20 20 20 65 6e 74 72 79 0a atch.. entry.
2440: 09 20 20 20 20 28 28 64 6e 61 6d 65 20 70 61 74 . ((dname pat
2450: 68 29 0a 09 20 20 20 20 20 28 70 72 69 6e 74 20 h).. (print
2460: 22 44 69 73 6b 20 22 20 64 6e 61 6d 65 20 22 20 "Disk " dname "
2470: 61 74 20 22 20 70 61 74 68 20 22 20 77 72 69 74 at " path " writ
2480: 65 61 62 6c 65 3a 20 22 0a 09 09 20 20 20 20 28 eable: "... (
2490: 69 66 20 28 63 68 65 63 6b 2d 77 72 69 74 65 2d if (check-write-
24a0: 63 72 65 61 74 65 20 70 61 74 68 29 20 22 79 65 create path) "ye
24b0: 73 22 20 22 4e 4f 22 29 29 29 0a 09 20 20 20 20 s" "NO")))..
24c0: 28 65 6c 73 65 20 28 70 72 69 6e 74 20 22 62 61 (else (print "ba
24d0: 64 20 65 6e 74 72 79 3a 20 22 20 65 6e 74 72 79 d entry: " entry
24e0: 29 29 29 29 0a 09 20 28 68 61 73 68 2d 74 61 62 )))).. (hash-tab
24f0: 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 63 le-ref/default c
2500: 64 61 74 20 22 64 69 73 6b 73 22 20 27 28 29 29 dat "disks" '())
2510: 29 29 29 0a 0a 20 20 28 70 72 69 6e 74 20 22 48 ))).. (print "H
2520: 61 76 65 20 6c 69 6e 6b 20 74 72 65 65 20 61 6e ave link tree an
2530: 64 20 69 74 20 69 73 20 77 72 69 74 61 62 6c 65 d it is writable
2540: 3a 20 22 0a 09 20 28 69 66 20 28 61 6e 64 20 28 : ".. (if (and (
2550: 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 22 6c 74 file-exists? "lt
2560: 22 29 0a 09 09 20 20 28 63 68 65 63 6b 2d 77 72 ")... (check-wr
2570: 69 74 65 2d 63 72 65 61 74 65 20 22 6c 74 22 29 ite-create "lt")
2580: 29 0a 09 20 20 20 20 20 22 79 65 73 22 0a 09 20 ).. "yes"..
2590: 20 20 20 20 22 4e 4f 22 29 29 0a 20 20 3b 3b 20 "NO")). ;;
25a0: 20 20 20 63 68 65 63 6b 20 6c 6f 61 64 20 6f 6e check load on
25b0: 20 68 6f 6d 65 68 6f 73 74 0a 20 20 29 0a 0a 3b homehost. )..;
25c0: 3b 20 44 65 76 65 6c 6f 70 20 73 74 75 66 66 20 ; Develop stuff
25d0: 68 65 72 65 20 2d 20 74 68 65 6e 20 6d 6f 76 65 here - then move
25e0: 20 74 6f 20 77 68 65 72 65 20 69 74 20 62 65 6c to where it bel
25f0: 6f 6e 67 73 2e 0a 0a 0a 29 0a ongs....).