Artifact
9fa9e34972e9b3f739477c0d0c9e62b9785d664f:
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 6d 6f 64 75 6c 65 20 6d 75 74 69 6c 73 0a .(module mutils.
01d0: 20 20 20 20 2a 0a 0a 20 20 28 69 6d 70 6f 72 74 *.. (import
01e0: 20 63 68 69 63 6b 65 6e 20 73 63 68 65 6d 65 0a chicken scheme.
01f0: 09 20 20 3b 3b 20 64 61 74 61 2d 73 74 72 75 63 . ;; data-struc
0200: 74 75 72 65 73 20 70 6f 73 69 78 0a 09 20 20 73 tures posix.. s
0210: 72 66 69 2d 31 0a 09 20 20 3b 3b 20 73 72 66 69 rfi-1.. ;; srfi
0220: 2d 31 33 0a 09 20 20 73 72 66 69 2d 36 39 0a 09 -13.. srfi-69..
0230: 20 20 70 6f 72 74 73 0a 09 20 20 65 78 74 72 61 ports.. extra
0240: 73 0a 09 20 20 72 65 67 65 78 0a 09 20 20 70 6f s.. regex.. po
0250: 73 69 78 0a 09 20 20 64 61 74 61 2d 73 74 72 75 six.. data-stru
0260: 63 74 75 72 65 73 0a 09 20 20 6d 61 74 63 68 61 ctures.. matcha
0270: 62 6c 65 0a 09 20 20 29 0a 0a 28 64 65 66 69 6e ble.. )..(defin
0280: 65 20 28 6d 75 74 69 6c 73 3a 68 69 65 72 68 61 e (mutils:hierha
0290: 73 68 2d 72 65 66 20 68 68 20 2e 20 6b 65 79 73 sh-ref hh . keys
02a0: 29 0a 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 6b ). (if (null? k
02b0: 65 79 73 29 0a 20 20 20 20 20 20 23 66 0a 20 20 eys). #f.
02c0: 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 (let loop ((
02d0: 68 74 20 20 20 68 68 29 0a 09 09 20 28 6b 65 79 ht hh)... (key
02e0: 20 20 28 63 61 72 20 6b 65 79 73 29 29 0a 09 09 (car keys))...
02f0: 20 28 74 61 69 6c 20 28 63 64 72 20 6b 65 79 73 (tail (cdr keys
0300: 29 29 29 0a 09 28 69 66 20 28 6e 75 6c 6c 3f 20 )))..(if (null?
0310: 74 61 69 6c 29 0a 09 20 20 20 20 28 69 66 20 28 tail).. (if (
0320: 68 61 73 68 2d 74 61 62 6c 65 3f 20 68 74 29 0a hash-table? ht).
0330: 09 09 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 ..(hash-table-re
0340: 66 2f 64 65 66 61 75 6c 74 20 68 74 20 6b 65 79 f/default ht key
0350: 20 23 66 29 0a 09 09 23 66 29 0a 09 20 20 20 20 #f)...#f)..
0360: 28 69 66 20 28 68 61 73 68 2d 74 61 62 6c 65 3f (if (hash-table?
0370: 20 68 74 29 0a 09 09 28 6c 6f 6f 70 20 28 68 61 ht)...(loop (ha
0380: 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 sh-table-ref/def
0390: 61 75 6c 74 20 68 74 20 6b 65 79 20 23 66 29 0a ault ht key #f).
03a0: 09 09 20 20 20 20 20 20 28 63 61 72 20 74 61 69 .. (car tai
03b0: 6c 29 0a 09 09 20 20 20 20 20 20 28 63 64 72 20 l)... (cdr
03c0: 74 61 69 6c 29 29 0a 09 09 23 66 29 29 29 29 29 tail))...#f)))))
03d0: 0a 0a 3b 3b 20 57 41 54 43 48 20 54 48 45 20 4e ..;; WATCH THE N
03e0: 4f 4e 2d 49 4e 54 55 49 54 49 56 45 20 49 4e 54 ON-INTUITIVE INT
03f0: 45 52 46 41 43 45 20 48 45 52 45 21 21 21 21 0a ERFACE HERE!!!!.
0400: 3b 3b 20 76 61 6c 20 63 6f 6d 65 73 20 66 69 72 ;; val comes fir
0410: 73 74 21 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 st!.;;.(define (
0420: 6d 75 74 69 6c 73 3a 68 69 65 72 68 61 73 68 2d mutils:hierhash-
0430: 73 65 74 21 20 68 68 20 76 61 6c 20 2e 20 6b 65 set! hh val . ke
0440: 79 73 29 0a 20 20 28 69 66 20 28 6e 75 6c 6c 3f ys). (if (null?
0450: 20 6b 65 79 73 29 0a 20 20 20 20 20 20 23 66 0a keys). #f.
0460: 20 20 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 (let loop
0470: 28 28 68 74 20 20 20 20 68 68 29 0a 09 09 20 28 ((ht hh)... (
0480: 6b 65 79 20 20 28 63 61 72 20 6b 65 79 73 29 29 key (car keys))
0490: 0a 09 09 20 28 74 61 69 6c 20 28 63 64 72 20 6b ... (tail (cdr k
04a0: 65 79 73 29 29 29 0a 09 28 69 66 20 28 6e 75 6c eys)))..(if (nul
04b0: 6c 3f 20 74 61 69 6c 29 20 3b 3b 20 6c 61 73 74 l? tail) ;; last
04c0: 20 6f 6e 65 21 0a 09 20 20 20 20 28 68 61 73 68 one!.. (hash
04d0: 2d 74 61 62 6c 65 2d 73 65 74 21 20 68 74 20 6b -table-set! ht k
04e0: 65 79 20 76 61 6c 29 0a 09 20 20 20 20 28 6c 65 ey val).. (le
04f0: 74 20 28 28 6e 68 20 28 68 61 73 68 2d 74 61 62 t ((nh (hash-tab
0500: 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 68 le-ref/default h
0510: 74 20 6b 65 79 20 23 66 29 29 29 0a 09 20 20 20 t key #f)))..
0520: 20 20 20 28 69 66 20 28 6e 6f 74 20 6e 68 29 28 (if (not nh)(
0530: 73 65 74 21 20 6e 68 20 28 6d 61 6b 65 2d 68 61 set! nh (make-ha
0540: 73 68 2d 74 61 62 6c 65 29 29 29 0a 09 20 20 20 sh-table)))..
0550: 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 (hash-table-s
0560: 65 74 21 20 68 74 20 6b 65 79 20 6e 68 29 0a 09 et! ht key nh)..
0570: 20 20 20 20 20 20 28 6c 6f 6f 70 20 6e 68 0a 09 (loop nh..
0580: 09 20 20 20 20 28 63 61 72 20 74 61 69 6c 29 0a . (car tail).
0590: 09 09 20 20 20 20 28 63 64 72 20 74 61 69 6c 29 .. (cdr tail)
05a0: 29 29 29 29 29 29 0a 0a 3b 3b 20 6e 69 63 65 20 ))))))..;; nice
05b0: 6c 69 74 74 6c 65 20 72 6f 75 74 69 6e 65 20 74 little routine t
05c0: 6f 20 61 64 64 20 61 6e 20 69 74 65 6d 20 74 6f o add an item to
05d0: 20 61 20 6c 69 73 74 20 69 6e 20 61 20 68 61 73 a list in a has
05e0: 68 74 61 62 6c 65 20 0a 3b 3b 0a 28 64 65 66 69 htable .;;.(defi
05f0: 6e 65 20 28 6d 75 74 69 6c 73 3a 68 61 73 68 2d ne (mutils:hash-
0600: 74 61 62 6c 65 2d 61 64 64 2d 74 6f 2d 6c 69 73 table-add-to-lis
0610: 74 20 68 74 62 6c 20 6b 65 79 20 69 74 65 6d 29 t htbl key item)
0620: 0a 20 20 28 6c 65 74 20 28 28 6c 20 28 68 61 73 . (let ((l (has
0630: 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 h-table-ref/defa
0640: 75 6c 74 20 68 74 62 6c 20 6b 65 79 20 23 66 29 ult htbl key #f)
0650: 29 29 0a 20 20 20 20 28 69 66 20 6c 0a 09 28 68 )). (if l..(h
0660: 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 68 ash-table-set! h
0670: 74 62 6c 20 6b 65 79 20 28 63 6f 6e 73 20 69 74 tbl key (cons it
0680: 65 6d 20 6c 29 29 0a 09 28 68 61 73 68 2d 74 61 em l))..(hash-ta
0690: 62 6c 65 2d 73 65 74 21 20 68 74 62 6c 20 6b 65 ble-set! htbl ke
06a0: 79 20 28 6c 69 73 74 20 69 74 65 6d 29 29 29 29 y (list item))))
06b0: 29 0a 0a 28 64 65 66 69 6e 65 20 28 6d 75 74 69 )..(define (muti
06c0: 6c 73 3a 68 61 73 68 2d 74 61 62 6c 65 2d 61 70 ls:hash-table-ap
06d0: 70 65 6e 64 2d 74 6f 2d 6c 69 73 74 20 68 74 62 pend-to-list htb
06e0: 6c 20 6b 65 79 20 6c 73 74 29 0a 20 20 28 6c 65 l key lst). (le
06f0: 74 20 28 28 6c 20 28 68 61 73 68 2d 74 61 62 6c t ((l (hash-tabl
0700: 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 68 74 e-ref/default ht
0710: 62 6c 20 6b 65 79 20 23 66 29 29 29 0a 20 20 20 bl key #f))).
0720: 20 28 69 66 20 6c 0a 09 28 68 61 73 68 2d 74 61 (if l..(hash-ta
0730: 62 6c 65 2d 73 65 74 21 20 68 74 62 6c 20 6b 65 ble-set! htbl ke
0740: 79 20 28 61 70 70 65 6e 64 20 6c 73 74 20 6c 29 y (append lst l)
0750: 29 0a 20 20 20 20 20 20 20 20 28 68 61 73 68 2d ). (hash-
0760: 74 61 62 6c 65 2d 73 65 74 21 20 68 74 62 6c 20 table-set! htbl
0770: 6b 65 79 20 6c 73 74 29 29 29 29 0a 0a 3b 3b 3d key lst))))..;;=
0780: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0790: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
07a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
07b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
07c0: 3d 3d 3d 3d 3d 0a 3b 3b 20 55 74 69 6c 73 0a 3b =====.;; Utils.;
07d0: 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;===============
07e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
07f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0800: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0810: 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 69 6e 65 =======..(define
0820: 20 28 6d 75 74 69 6c 73 3a 66 69 6c 65 2d 3e 6c (mutils:file->l
0830: 69 73 74 20 66 6e 61 6d 65 29 0a 20 20 28 6c 65 ist fname). (le
0840: 74 20 28 28 66 68 20 28 6f 70 65 6e 2d 69 6e 70 t ((fh (open-inp
0850: 75 74 2d 66 69 6c 65 20 66 6e 61 6d 65 29 29 0a ut-file fname)).
0860: 09 28 63 6f 6d 6d 65 6e 74 20 28 72 65 67 65 78 .(comment (regex
0870: 70 20 22 5e 5c 5c 73 2a 23 22 29 29 0a 09 28 62 p "^\\s*#"))..(b
0880: 6c 61 6e 6b 20 20 20 28 72 65 67 65 78 70 20 22 lank (regexp "
0890: 5e 5c 5c 73 2a 24 22 29 29 29 0a 20 20 20 20 28 ^\\s*$"))). (
08a0: 6c 65 74 20 6c 6f 6f 70 20 28 28 6c 20 20 20 28 let loop ((l (
08b0: 72 65 61 64 2d 6c 69 6e 65 20 66 68 29 29 0a 09 read-line fh))..
08c0: 20 20 20 20 20 20 20 28 72 65 73 20 27 28 29 29 (res '())
08d0: 29 0a 20 20 20 20 20 20 28 69 66 20 28 65 6f 66 ). (if (eof
08e0: 2d 6f 62 6a 65 63 74 3f 20 6c 29 0a 09 20 20 28 -object? l).. (
08f0: 72 65 76 65 72 73 65 20 72 65 73 29 0a 09 20 20 reverse res)..
0900: 28 69 66 20 28 6f 72 20 28 73 74 72 69 6e 67 2d (if (or (string-
0910: 6d 61 74 63 68 20 63 6f 6d 6d 65 6e 74 20 6c 29 match comment l)
0920: 0a 09 09 20 20 28 73 74 72 69 6e 67 2d 6d 61 74 ... (string-mat
0930: 63 68 20 62 6c 61 6e 6b 20 6c 29 29 0a 09 20 20 ch blank l))..
0940: 20 20 20 20 28 6c 6f 6f 70 20 28 72 65 61 64 2d (loop (read-
0950: 6c 69 6e 65 20 66 68 29 20 72 65 73 29 0a 09 20 line fh) res)..
0960: 20 20 20 20 20 28 6c 6f 6f 70 20 28 72 65 61 64 (loop (read
0970: 2d 6c 69 6e 65 20 66 68 29 20 28 63 6f 6e 73 20 -line fh) (cons
0980: 6c 20 72 65 73 29 29 29 29 29 29 29 0a 0a 28 75 l res)))))))..(u
0990: 73 65 20 73 70 61 72 73 65 2d 76 65 63 74 6f 72 se sparse-vector
09a0: 73 29 0a 0a 3b 3b 20 74 68 69 73 20 69 73 20 61 s)..;; this is a
09b0: 20 73 69 6d 70 6c 65 20 74 77 6f 20 64 69 6d 65 simple two dime
09c0: 6e 73 69 6f 6e 61 6c 20 73 70 61 72 73 65 20 61 nsional sparse a
09d0: 72 72 61 79 0a 0a 3b 3b 20 4f 4e 4c 59 20 54 57 rray..;; ONLY TW
09e0: 4f 20 44 49 4d 45 4e 53 49 4f 4e 53 21 21 21 20 O DIMENSIONS!!!
09f0: 53 45 45 20 41 52 52 41 59 2d 4c 49 42 20 49 46 SEE ARRAY-LIB IF
0a00: 20 59 4f 55 52 20 4e 45 45 44 53 20 41 52 45 20 YOUR NEEDS ARE
0a10: 47 52 45 41 54 45 52 21 21 0a 3b 3b 0a 28 64 65 GREATER!!.;;.(de
0a20: 66 69 6e 65 20 28 6d 75 74 69 6c 73 3a 6d 61 6b fine (mutils:mak
0a30: 65 2d 73 70 61 72 73 65 2d 61 72 72 61 79 29 0a e-sparse-array).
0a40: 20 20 28 6c 65 74 20 28 28 61 20 28 6d 61 6b 65 (let ((a (make
0a50: 2d 73 70 61 72 73 65 2d 76 65 63 74 6f 72 29 29 -sparse-vector))
0a60: 29 0a 20 20 20 20 28 73 70 61 72 73 65 2d 76 65 ). (sparse-ve
0a70: 63 74 6f 72 2d 73 65 74 21 20 61 20 30 20 28 6d ctor-set! a 0 (m
0a80: 61 6b 65 2d 73 70 61 72 73 65 2d 76 65 63 74 6f ake-sparse-vecto
0a90: 72 29 29 0a 20 20 20 20 61 29 29 0a 0a 28 64 65 r)). a))..(de
0aa0: 66 69 6e 65 20 28 6d 75 74 69 6c 73 3a 73 70 61 fine (mutils:spa
0ab0: 72 73 65 2d 61 72 72 61 79 3f 20 61 29 0a 20 20 rse-array? a).
0ac0: 28 61 6e 64 20 28 73 70 61 72 73 65 2d 76 65 63 (and (sparse-vec
0ad0: 74 6f 72 3f 20 61 29 0a 20 20 20 20 20 20 20 28 tor? a). (
0ae0: 73 70 61 72 73 65 2d 76 65 63 74 6f 72 3f 20 28 sparse-vector? (
0af0: 73 70 61 72 73 65 2d 76 65 63 74 6f 72 2d 72 65 sparse-vector-re
0b00: 66 20 61 20 30 29 29 29 29 0a 0a 28 64 65 66 69 f a 0))))..(defi
0b10: 6e 65 20 28 6d 75 74 69 6c 73 3a 73 70 61 72 73 ne (mutils:spars
0b20: 65 2d 61 72 72 61 79 2d 72 65 66 20 61 20 78 20 e-array-ref a x
0b30: 79 29 0a 20 20 28 6c 65 74 20 28 28 72 6f 77 20 y). (let ((row
0b40: 28 73 70 61 72 73 65 2d 76 65 63 74 6f 72 2d 72 (sparse-vector-r
0b50: 65 66 20 61 20 78 29 29 29 0a 20 20 20 20 28 69 ef a x))). (i
0b60: 66 20 72 6f 77 0a 09 28 73 70 61 72 73 65 2d 76 f row..(sparse-v
0b70: 65 63 74 6f 72 2d 72 65 66 20 72 6f 77 20 79 29 ector-ref row y)
0b80: 0a 09 23 66 29 29 29 0a 0a 28 64 65 66 69 6e 65 ..#f)))..(define
0b90: 20 28 6d 75 74 69 6c 73 3a 73 70 61 72 73 65 2d (mutils:sparse-
0ba0: 61 72 72 61 79 2d 73 65 74 21 20 61 20 78 20 79 array-set! a x y
0bb0: 20 76 61 6c 29 0a 20 20 28 6c 65 74 20 28 28 72 val). (let ((r
0bc0: 6f 77 20 28 73 70 61 72 73 65 2d 76 65 63 74 6f ow (sparse-vecto
0bd0: 72 2d 72 65 66 20 61 20 78 29 29 29 0a 20 20 20 r-ref a x))).
0be0: 20 28 69 66 20 72 6f 77 0a 09 28 73 70 61 72 73 (if row..(spars
0bf0: 65 2d 76 65 63 74 6f 72 2d 73 65 74 21 20 72 6f e-vector-set! ro
0c00: 77 20 79 20 76 61 6c 29 0a 09 28 6c 65 74 20 28 w y val)..(let (
0c10: 28 6e 65 77 2d 72 6f 77 20 28 6d 61 6b 65 2d 73 (new-row (make-s
0c20: 70 61 72 73 65 2d 76 65 63 74 6f 72 29 29 29 0a parse-vector))).
0c30: 09 20 20 28 73 70 61 72 73 65 2d 76 65 63 74 6f . (sparse-vecto
0c40: 72 2d 73 65 74 21 20 61 20 78 20 6e 65 77 2d 72 r-set! a x new-r
0c50: 6f 77 29 0a 09 20 20 28 73 70 61 72 73 65 2d 76 ow).. (sparse-v
0c60: 65 63 74 6f 72 2d 73 65 74 21 20 6e 65 77 2d 72 ector-set! new-r
0c70: 6f 77 20 79 20 76 61 6c 29 29 29 29 29 0a 0a 3b ow y val)))))..;
0c80: 3b 20 73 6f 6d 65 20 72 6f 75 74 69 6e 65 73 20 ; some routines
0c90: 66 6f 72 20 74 72 65 61 74 69 6e 67 20 61 73 73 for treating ass
0ca0: 6f 63 20 6c 69 73 74 73 20 61 20 62 69 74 20 6c oc lists a bit l
0cb0: 69 6b 65 20 68 61 73 68 20 74 61 62 6c 65 73 0a ike hash tables.
0cc0: 0a 28 64 65 66 69 6e 65 20 28 6d 75 74 69 6c 73 .(define (mutils
0cd0: 3a 61 73 73 6f 63 2d 67 65 74 2f 64 65 66 61 75 :assoc-get/defau
0ce0: 6c 74 20 61 6c 69 73 74 20 6b 65 79 20 64 65 66 lt alist key def
0cf0: 61 75 6c 74 29 0a 20 20 28 6c 65 74 20 28 28 72 ault). (let ((r
0d00: 65 73 20 28 61 73 73 6f 63 20 6b 65 79 20 61 6c es (assoc key al
0d10: 69 73 74 29 29 29 0a 20 20 20 20 28 69 66 20 28 ist))). (if (
0d20: 61 6e 64 20 72 65 73 20 28 6c 69 73 74 3f 20 72 and res (list? r
0d30: 65 73 29 28 3e 20 28 6c 65 6e 67 74 68 20 72 65 es)(> (length re
0d40: 73 29 20 31 29 29 0a 09 28 63 61 64 72 20 72 65 s) 1))..(cadr re
0d50: 73 29 0a 09 64 65 66 61 75 6c 74 29 29 29 0a 0a s)..default)))..
0d60: 28 64 65 66 69 6e 65 20 28 6d 75 74 69 6c 73 3a (define (mutils:
0d70: 61 73 73 6f 63 2d 67 65 74 20 61 6c 69 73 74 20 assoc-get alist
0d80: 6b 65 79 29 0a 20 20 28 63 61 64 72 20 28 61 73 key). (cadr (as
0d90: 73 6f 63 20 6b 65 79 20 61 6c 69 73 74 29 29 29 soc key alist)))
0da0: 0a 0a 28 64 65 66 69 6e 65 20 28 6d 75 74 69 6c ..(define (mutil
0db0: 73 3a 68 69 65 72 2d 6c 69 73 74 3f 20 40 68 69 s:hier-list? @hi
0dc0: 65 72 6c 69 73 74 29 0a 20 20 28 61 6e 64 20 28 erlist). (and (
0dd0: 6c 69 73 74 3f 20 40 68 69 65 72 6c 69 73 74 29 list? @hierlist)
0de0: 0a 20 20 20 20 20 20 20 28 3e 20 28 6c 65 6e 67 . (> (leng
0df0: 74 68 20 40 68 69 65 72 6c 69 73 74 29 20 30 29 th @hierlist) 0)
0e00: 0a 20 20 20 20 20 20 20 28 6c 69 73 74 3f 20 28 . (list? (
0e10: 63 61 72 20 40 68 69 65 72 6c 69 73 74 29 29 0a car @hierlist)).
0e20: 20 20 20 20 20 20 20 28 3e 20 28 6c 65 6e 67 74 (> (lengt
0e30: 68 20 28 63 61 72 20 40 68 69 65 72 6c 69 73 74 h (car @hierlist
0e40: 29 29 20 31 29 29 29 0a 0a 28 64 65 66 69 6e 65 )) 1)))..(define
0e50: 20 28 6d 75 74 69 6c 73 3a 68 69 65 72 2d 6c 69 (mutils:hier-li
0e60: 73 74 2d 67 65 74 20 40 68 69 65 72 6c 69 73 74 st-get @hierlist
0e70: 20 2e 20 40 70 61 74 68 29 0a 20 20 28 69 66 20 . @path). (if
0e80: 28 6c 69 73 74 3f 20 40 68 69 65 72 6c 69 73 74 (list? @hierlist
0e90: 29 0a 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 ). (let* ((
0ea0: 24 70 61 74 68 20 28 63 61 72 20 40 70 61 74 68 $path (car @path
0eb0: 29 29 0a 09 20 20 20 20 20 28 40 72 65 6d 70 61 )).. (@rempa
0ec0: 74 68 20 28 63 64 72 20 40 70 61 74 68 29 29 0a th (cdr @path)).
0ed0: 09 20 20 20 20 20 28 40 6d 61 74 63 68 20 28 61 . (@match (a
0ee0: 73 73 6f 63 20 24 70 61 74 68 20 40 68 69 65 72 ssoc $path @hier
0ef0: 6c 69 73 74 29 29 29 0a 09 28 69 66 20 40 6d 61 list)))..(if @ma
0f00: 74 63 68 0a 09 20 20 20 20 28 69 66 20 28 6f 72 tch.. (if (or
0f10: 20 28 6e 6f 74 20 28 6c 69 73 74 3f 20 40 72 65 (not (list? @re
0f20: 6d 70 61 74 68 29 29 28 6e 75 6c 6c 3f 20 40 72 mpath))(null? @r
0f30: 65 6d 70 61 74 68 29 29 0a 09 09 28 63 61 64 72 empath))...(cadr
0f40: 20 40 6d 61 74 63 68 29 0a 09 09 28 61 70 70 6c @match)...(appl
0f50: 79 20 6d 75 74 69 6c 73 3a 68 69 65 72 2d 6c 69 y mutils:hier-li
0f60: 73 74 2d 67 65 74 20 28 63 61 64 72 20 40 6d 61 st-get (cadr @ma
0f70: 74 63 68 29 20 40 72 65 6d 70 61 74 68 29 29 0a tch) @rempath)).
0f80: 09 20 20 20 20 23 66 29 29 0a 20 20 20 20 20 20 . #f)).
0f90: 23 66 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 6d #f))..(define (m
0fa0: 75 74 69 6c 73 3a 68 69 65 72 2d 6c 69 73 74 2d utils:hier-list-
0fb0: 70 75 74 21 20 40 68 69 65 72 6c 69 73 74 20 2e put! @hierlist .
0fc0: 20 40 70 61 74 68 29 0a 20 20 28 6c 65 74 2a 20 @path). (let*
0fd0: 28 28 24 70 61 74 68 20 28 63 61 72 20 40 70 61 (($path (car @pa
0fe0: 74 68 29 29 0a 09 20 28 40 72 65 6d 70 61 74 68 th)).. (@rempath
0ff0: 20 28 63 64 72 20 40 70 61 74 68 29 29 0a 09 20 (cdr @path))..
1000: 28 24 76 61 6c 75 65 20 20 20 28 63 61 64 72 20 ($value (cadr
1010: 40 70 61 74 68 29 29 0a 09 20 28 40 6d 61 74 63 @path)).. (@matc
1020: 68 20 28 61 73 73 6f 63 20 24 70 61 74 68 20 40 h (assoc $path @
1030: 68 69 65 72 6c 69 73 74 29 29 0a 09 20 28 40 72 hierlist)).. (@r
1040: 65 6d 68 69 65 72 6c 69 73 74 20 28 72 65 6d 6f emhierlist (remo
1050: 76 65 20 28 6c 61 6d 62 64 61 20 28 61 29 0a 20 ve (lambda (a).
1060: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1070: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1080: 28 65 71 75 61 6c 3f 20 61 20 40 6d 61 74 63 68 (equal? a @match
1090: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
10a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
10b0: 20 20 40 68 69 65 72 6c 69 73 74 29 29 0a 20 20 @hierlist)).
10c0: 20 20 20 20 20 20 20 28 40 6f 6c 64 2d 70 61 69 (@old-pai
10d0: 72 20 28 6c 65 74 20 28 28 24 76 61 6c 75 65 20 r (let (($value
10e0: 28 6d 75 74 69 6c 73 3a 68 69 65 72 2d 6c 69 73 (mutils:hier-lis
10f0: 74 2d 67 65 74 20 40 68 69 65 72 6c 69 73 74 20 t-get @hierlist
1100: 24 70 61 74 68 29 29 29 20 28 69 66 20 24 76 61 $path))) (if $va
1110: 6c 75 65 20 24 76 61 6c 75 65 20 27 28 29 29 29 lue $value '()))
1120: 29 0a 09 20 28 40 6e 65 77 2d 70 61 69 72 20 28 ).. (@new-pair (
1130: 6c 69 73 74 20 24 70 61 74 68 20 28 69 66 20 28 list $path (if (
1140: 65 71 3f 20 28 6c 65 6e 67 74 68 20 40 72 65 6d eq? (length @rem
1150: 70 61 74 68 29 20 31 29 20 0a 09 09 09 09 20 20 path) 1) .....
1160: 20 20 28 63 61 72 20 40 72 65 6d 70 61 74 68 29 (car @rempath)
1170: 0a 09 09 09 09 20 20 20 20 28 61 70 70 6c 79 20 ..... (apply
1180: 6d 75 74 69 6c 73 3a 68 69 65 72 2d 6c 69 73 74 mutils:hier-list
1190: 2d 70 75 74 21 20 40 6f 6c 64 2d 70 61 69 72 20 -put! @old-pair
11a0: 40 72 65 6d 70 61 74 68 29 29 29 29 29 0a 20 20 @rempath))))).
11b0: 20 20 28 63 6f 6e 73 20 40 6e 65 77 2d 70 61 69 (cons @new-pai
11c0: 72 20 40 72 65 6d 68 69 65 72 6c 69 73 74 29 29 r @remhierlist))
11d0: 29 0a 0a 28 64 65 66 69 6e 65 20 28 6d 75 74 69 )..(define (muti
11e0: 6c 73 3a 68 69 65 72 2d 6c 69 73 74 2d 72 65 6d ls:hier-list-rem
11f0: 6f 76 65 21 20 40 68 69 65 72 6c 69 73 74 20 2e ove! @hierlist .
1200: 20 40 70 61 74 68 29 0a 20 20 28 6c 65 74 20 28 @path). (let (
1210: 28 24 70 61 74 68 20 28 63 61 72 20 40 70 61 74 ($path (car @pat
1220: 68 29 29 29 0a 20 20 20 20 28 69 66 20 28 65 71 h))). (if (eq
1230: 3f 20 28 6c 65 6e 67 74 68 20 40 70 61 74 68 29 ? (length @path)
1240: 20 31 29 0a 09 28 72 65 6d 6f 76 65 20 28 6c 61 1)..(remove (la
1250: 6d 62 64 61 20 28 61 29 0a 20 20 20 20 20 20 20 mbda (a).
1260: 20 20 20 20 20 20 20 20 20 20 20 28 65 71 75 61 (equa
1270: 6c 3f 20 61 20 28 61 73 73 6f 63 20 24 70 61 74 l? a (assoc $pat
1280: 68 20 40 68 69 65 72 6c 69 73 74 29 29 29 0a 20 h @hierlist))).
1290: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 40 @
12a0: 68 69 65 72 6c 69 73 74 29 0a 09 28 6c 65 74 2a hierlist)..(let*
12b0: 20 28 28 40 72 65 6d 70 61 74 68 20 28 63 64 72 ((@rempath (cdr
12c0: 20 40 70 61 74 68 29 29 0a 09 20 20 20 20 20 20 @path))..
12d0: 20 28 40 6d 61 74 63 68 20 28 61 73 73 6f 63 20 (@match (assoc
12e0: 24 70 61 74 68 20 40 68 69 65 72 6c 69 73 74 29 $path @hierlist)
12f0: 29 0a 09 20 20 20 20 20 20 20 28 40 72 65 6d 68 ).. (@remh
1300: 69 65 72 6c 69 73 74 20 28 72 65 6d 6f 76 65 20 ierlist (remove
1310: 28 6c 61 6d 62 64 61 20 28 61 29 20 0a 20 20 20 (lambda (a) .
1320: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1330: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1340: 20 20 20 20 28 65 71 75 61 6c 3f 20 40 6d 61 74 (equal? @mat
1350: 63 68 20 61 29 29 0a 20 20 20 20 20 20 20 20 20 ch a)).
1360: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1370: 20 20 20 20 20 20 20 20 20 20 20 20 40 68 69 65 @hie
1380: 72 6c 69 73 74 29 29 0a 09 20 20 20 20 20 20 20 rlist))..
1390: 28 40 6f 6c 64 2d 70 61 69 72 20 28 6c 65 74 20 (@old-pair (let
13a0: 28 28 24 76 61 6c 75 65 20 28 6d 75 74 69 6c 73 (($value (mutils
13b0: 3a 68 69 65 72 2d 6c 69 73 74 2d 67 65 74 20 40 :hier-list-get @
13c0: 68 69 65 72 6c 69 73 74 20 24 70 61 74 68 29 29 hierlist $path))
13d0: 29 20 28 69 66 20 24 76 61 6c 75 65 20 24 76 61 ) (if $value $va
13e0: 6c 75 65 20 27 28 29 29 29 29 0a 09 20 20 20 20 lue '())))..
13f0: 20 20 20 28 40 6e 65 77 2d 70 61 69 72 20 28 6c (@new-pair (l
1400: 69 73 74 20 24 70 61 74 68 20 28 61 70 70 6c 79 ist $path (apply
1410: 20 6d 75 74 69 6c 73 3a 68 69 65 72 2d 6c 69 73 mutils:hier-lis
1420: 74 2d 72 65 6d 6f 76 65 21 20 40 6f 6c 64 2d 70 t-remove! @old-p
1430: 61 69 72 20 40 72 65 6d 70 61 74 68 29 29 29 29 air @rempath))))
1440: 0a 09 20 20 28 63 6f 6e 73 20 40 6e 65 77 2d 70 .. (cons @new-p
1450: 61 69 72 20 40 72 65 6d 68 69 65 72 6c 69 73 74 air @remhierlist
1460: 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 )))))..(define (
1470: 6d 75 74 69 6c 73 3a 6b 65 79 73 20 40 68 69 65 mutils:keys @hie
1480: 72 6c 69 73 74 20 2e 20 40 70 61 74 68 29 0a 20 rlist . @path).
1490: 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 40 (map (lambda (@
14a0: 6c 29 0a 09 20 28 69 66 20 28 61 6e 64 20 28 6c l).. (if (and (l
14b0: 69 73 74 3f 20 40 6c 29 28 6e 6f 74 20 28 6e 75 ist? @l)(not (nu
14c0: 6c 6c 3f 20 40 6c 29 29 29 20 0a 09 20 20 20 20 ll? @l))) ..
14d0: 20 28 63 61 72 20 40 6c 29 29 29 20 0a 20 20 20 (car @l))) .
14e0: 20 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 40 (if (null? @
14f0: 70 61 74 68 29 20 40 68 69 65 72 6c 69 73 74 0a path) @hierlist.
1500: 09 20 20 20 28 61 70 70 6c 79 20 6d 75 74 69 6c . (apply mutil
1510: 73 3a 68 69 65 72 2d 6c 69 73 74 2d 67 65 74 20 s:hier-list-get
1520: 40 68 69 65 72 6c 69 73 74 20 40 70 61 74 68 29 @hierlist @path)
1530: 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d )))..;;=========
1540: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1550: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1560: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1570: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b =============.;;
1580: 20 4f 74 68 65 72 20 75 74 69 6c 73 0a 3b 3b 3d Other utils.;;=
1590: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
15a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
15b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
15c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
15d0: 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 69 6e 65 20 28 =====..(define (
15e0: 63 68 65 63 6b 2d 77 72 69 74 65 2d 63 72 65 61 check-write-crea
15f0: 74 65 20 66 70 61 74 68 29 0a 20 20 28 61 6e 64 te fpath). (and
1600: 20 28 66 69 6c 65 2d 77 72 69 74 65 2d 61 63 63 (file-write-acc
1610: 65 73 73 3f 20 66 70 61 74 68 29 0a 20 20 20 20 ess? fpath).
1620: 20 20 20 28 6c 65 74 20 28 28 66 6e 61 6d 65 20 (let ((fname
1630: 28 63 6f 6e 63 20 66 70 61 74 68 20 22 2f 2e 6a (conc fpath "/.j
1640: 75 6e 6b 2d 22 20 28 63 75 72 72 65 6e 74 2d 73 unk-" (current-s
1650: 65 63 6f 6e 64 73 29 20 22 2d 22 20 28 72 61 6e econds) "-" (ran
1660: 64 6f 6d 20 31 30 30 30 30 29 29 29 29 0a 09 20 dom 10000))))..
1670: 3b 3b 28 70 72 69 6e 74 20 22 74 72 79 69 6e 67 ;;(print "trying
1680: 20 74 6f 20 63 72 65 61 74 65 2f 72 65 6d 6f 76 to create/remov
1690: 65 20 22 20 66 6e 61 6d 65 29 0a 09 20 28 68 61 e " fname).. (ha
16a0: 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a ndle-exceptions.
16b0: 09 20 20 65 78 6e 0a 09 20 20 23 66 0a 09 20 20 . exn.. #f..
16c0: 28 62 65 67 69 6e 0a 09 20 20 20 20 28 77 69 74 (begin.. (wit
16d0: 68 2d 6f 75 74 70 75 74 2d 74 6f 2d 66 69 6c 65 h-output-to-file
16e0: 20 66 6e 61 6d 65 0a 09 20 20 20 20 20 20 28 6c fname.. (l
16f0: 61 6d 62 64 61 20 28 29 0a 09 09 28 70 72 69 6e ambda ()...(prin
1700: 74 20 22 59 6f 75 20 63 61 6e 20 64 65 6c 65 74 t "You can delet
1710: 65 20 74 68 69 73 20 66 69 6c 65 22 29 29 29 0a e this file"))).
1720: 09 20 20 20 20 28 64 65 6c 65 74 65 2d 66 69 6c . (delete-fil
1730: 65 20 66 6e 61 6d 65 29 0a 09 20 20 20 20 23 74 e fname).. #t
1740: 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 )))))..(define (
1750: 72 75 6e 2d 61 6e 64 2d 72 65 74 75 72 6e 2d 6f run-and-return-o
1760: 75 74 70 75 74 20 63 6d 64 20 2e 20 70 61 72 61 utput cmd . para
1770: 6d 73 29 0a 20 20 28 6c 65 74 2d 76 61 6c 75 65 ms). (let-value
1780: 73 20 28 28 28 69 6e 70 20 6f 75 70 20 70 69 64 s (((inp oup pid
1790: 29 0a 09 09 28 70 72 6f 63 65 73 73 20 63 6d 64 )...(process cmd
17a0: 20 70 61 72 61 6d 73 29 29 29 0a 20 20 20 20 28 params))). (
17b0: 6c 65 74 20 28 28 72 65 73 20 28 77 69 74 68 2d let ((res (with-
17c0: 69 6e 70 75 74 2d 66 72 6f 6d 2d 70 6f 72 74 20 input-from-port
17d0: 69 6e 70 20 72 65 61 64 2d 6c 69 6e 65 73 29 29 inp read-lines))
17e0: 29 0a 20 20 20 20 20 20 28 6c 65 74 2d 76 61 6c ). (let-val
17f0: 75 65 73 20 28 28 28 70 69 64 72 65 73 20 73 74 ues (((pidres st
1800: 61 74 75 73 20 65 73 74 61 74 75 73 29 0a 09 09 atus estatus)...
1810: 20 20 20 20 28 70 72 6f 63 65 73 73 2d 77 61 69 (process-wai
1820: 74 20 70 69 64 29 29 29 0a 09 28 61 6e 64 20 73 t pid)))..(and s
1830: 74 61 74 75 73 20 28 65 71 3f 20 65 73 74 61 74 tatus (eq? estat
1840: 75 73 20 30 29 20 72 65 73 29 29 29 29 29 0a 0a us 0) res)))))..
1850: 28 64 65 66 69 6e 65 20 28 63 6f 6e 66 69 72 6d (define (confirm
1860: 2d 73 73 68 2d 61 63 63 65 73 73 2d 74 6f 2d 68 -ssh-access-to-h
1870: 6f 73 74 20 68 6f 73 74 6e 61 6d 65 29 0a 20 20 ost hostname).
1880: 28 72 75 6e 2d 61 6e 64 2d 72 65 74 75 72 6e 2d (run-and-return-
1890: 6f 75 74 70 75 74 20 22 73 73 68 22 20 68 6f 73 output "ssh" hos
18a0: 74 6e 61 6d 65 20 22 75 70 74 69 6d 65 22 29 29 tname "uptime"))
18b0: 0a 0a 28 64 65 66 69 6e 65 20 28 63 68 65 63 6b ..(define (check
18c0: 2d 64 69 73 70 6c 61 79 20 64 73 70 29 0a 20 20 -display dsp).
18d0: 28 72 75 6e 2d 61 6e 64 2d 72 65 74 75 72 6e 2d (run-and-return-
18e0: 6f 75 74 70 75 74 20 22 78 64 70 79 69 6e 66 6f output "xdpyinfo
18f0: 22 20 22 2d 64 69 73 70 6c 61 79 22 20 64 73 70 " "-display" dsp
1900: 29 29 0a 0a 23 3b 28 64 65 66 69 6e 65 20 28 63 ))..#;(define (c
1910: 68 65 63 6b 2d 64 69 73 70 6c 61 79 20 64 73 70 heck-display dsp
1920: 29 0a 20 20 28 6c 65 74 2d 76 61 6c 75 65 73 20 ). (let-values
1930: 28 28 28 69 6e 70 20 6f 75 70 20 70 69 64 29 0a (((inp oup pid).
1940: 09 09 28 70 72 6f 63 65 73 73 20 22 78 64 70 79 ..(process "xdpy
1950: 69 6e 66 6f 22 20 60 28 22 2d 64 69 73 70 6c 61 info" `("-displa
1960: 79 22 20 2c 64 73 70 29 29 29 29 0a 20 20 20 20 y" ,dsp)))).
1970: 28 6c 65 74 20 28 28 72 65 73 20 28 77 69 74 68 (let ((res (with
1980: 2d 69 6e 70 75 74 2d 66 72 6f 6d 2d 70 6f 72 74 -input-from-port
1990: 20 69 6e 70 20 72 65 61 64 2d 6c 69 6e 65 73 29 inp read-lines)
19a0: 29 29 0a 20 20 20 20 20 20 28 6c 65 74 2d 76 61 )). (let-va
19b0: 6c 75 65 73 20 28 28 28 70 69 64 72 65 73 20 73 lues (((pidres s
19c0: 74 61 74 75 73 20 65 73 74 61 74 75 73 29 0a 09 tatus estatus)..
19d0: 09 20 20 20 20 28 70 72 6f 63 65 73 73 2d 77 61 . (process-wa
19e0: 69 74 20 70 69 64 29 29 29 0a 09 28 61 6e 64 20 it pid)))..(and
19f0: 73 74 61 74 75 73 20 28 65 71 3f 20 65 73 74 61 status (eq? esta
1a00: 74 75 73 20 30 29 20 72 65 73 29 29 29 29 29 0a tus 0) res))))).
1a10: 0a 3b 3b 20 64 6f 20 73 6f 6d 65 20 73 61 6e 69 .;; do some sani
1a20: 74 79 20 63 68 65 63 6b 73 20 6f 6e 20 74 68 65 ty checks on the
1a30: 20 73 79 73 74 65 6d 0a 3b 3b 0a 28 64 65 66 69 system.;;.(defi
1a40: 6e 65 20 28 6d 75 74 69 6c 73 3a 73 79 73 63 68 ne (mutils:sysch
1a50: 65 63 6b 20 63 6f 6d 6d 6f 6e 3a 72 61 77 2d 67 eck common:raw-g
1a60: 65 74 2d 72 65 6d 6f 74 65 2d 68 6f 73 74 2d 6c et-remote-host-l
1a70: 6f 61 64 0a 09 09 09 20 73 65 72 76 65 72 3a 67 oad.... server:g
1a80: 65 74 2d 62 65 73 74 2d 67 75 65 73 73 2d 61 64 et-best-guess-ad
1a90: 64 72 65 73 73 0a 09 09 09 20 72 65 61 64 2d 63 dress.... read-c
1aa0: 6f 6e 66 69 67 29 0a 20 20 3b 3b 20 63 75 72 72 onfig). ;; curr
1ab0: 65 6e 74 20 64 69 72 20 77 72 69 74 65 61 62 6c ent dir writeabl
1ac0: 65 20 61 6e 64 20 64 6f 20 6d 65 67 61 74 65 73 e and do megates
1ad0: 74 2e 63 6f 6e 66 69 67 2c 20 72 75 6e 63 6f 6e t.config, runcon
1ae0: 66 69 67 73 2e 63 6f 6e 66 69 67 20 66 69 6c 65 figs.config file
1af0: 73 20 65 78 69 73 74 2f 72 65 61 64 61 62 6c 65 s exist/readable
1b00: 0a 20 20 28 70 72 69 6e 74 20 22 43 75 72 72 65 . (print "Curre
1b10: 6e 74 20 64 69 72 65 63 74 6f 72 79 20 22 20 28 nt directory " (
1b20: 63 75 72 72 65 6e 74 2d 64 69 72 65 63 74 6f 72 current-director
1b30: 79 29 20 22 20 77 72 69 74 65 61 62 6c 65 3a 20 y) " writeable:
1b40: 22 20 0a 09 20 28 69 66 20 28 63 68 65 63 6b 2d " .. (if (check-
1b50: 77 72 69 74 65 2d 63 72 65 61 74 65 20 22 2e 22 write-create "."
1b60: 29 20 22 79 65 73 22 20 22 4e 4f 22 29 29 0a 20 ) "yes" "NO")).
1b70: 20 3b 3b 20 68 6f 6d 65 20 64 69 72 20 77 72 69 ;; home dir wri
1b80: 74 65 61 62 6c 65 0a 20 20 28 70 72 69 6e 74 20 teable. (print
1b90: 22 48 6f 6d 65 20 64 69 72 65 63 74 6f 72 79 20 "Home directory
1ba0: 22 20 28 67 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 " (get-environme
1bb0: 6e 74 2d 76 61 72 69 61 62 6c 65 20 22 48 4f 4d nt-variable "HOM
1bc0: 45 22 29 20 22 20 77 72 69 74 65 61 62 6c 65 3a E") " writeable:
1bd0: 20 22 0a 09 20 28 69 66 20 28 63 68 65 63 6b 2d ".. (if (check-
1be0: 77 72 69 74 65 2d 63 72 65 61 74 65 20 28 67 65 write-create (ge
1bf0: 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 t-environment-va
1c00: 72 69 61 62 6c 65 20 22 48 4f 4d 45 22 29 29 20 riable "HOME"))
1c10: 22 79 65 73 22 20 22 4e 4f 22 29 29 0a 20 20 3b "yes" "NO")). ;
1c20: 3b 20 2f 74 6d 70 20 77 72 69 74 65 61 62 6c 65 ; /tmp writeable
1c30: 0a 20 20 28 70 72 69 6e 74 20 22 2f 74 6d 70 20 . (print "/tmp
1c40: 64 69 72 65 63 74 6f 72 79 20 77 72 69 74 65 61 directory writea
1c50: 62 6c 65 3a 20 22 20 28 69 66 20 28 63 68 65 63 ble: " (if (chec
1c60: 6b 2d 77 72 69 74 65 2d 63 72 65 61 74 65 20 22 k-write-create "
1c70: 2f 74 6d 70 22 29 20 22 79 65 73 22 20 22 4e 4f /tmp") "yes" "NO
1c80: 22 29 29 0a 20 20 3b 3b 20 6c 6f 61 64 20 63 6f ")). ;; load co
1c90: 6e 66 69 67 73 0a 20 20 28 70 72 69 6e 74 20 22 nfigs. (print "
1ca0: 24 44 49 53 50 4c 41 59 20 73 65 74 3a 20 22 20 $DISPLAY set: "
1cb0: 28 69 66 20 28 67 65 74 2d 65 6e 76 69 72 6f 6e (if (get-environ
1cc0: 6d 65 6e 74 2d 76 61 72 69 61 62 6c 65 20 22 44 ment-variable "D
1cd0: 49 53 50 4c 41 59 22 29 0a 09 09 09 20 20 20 20 ISPLAY")....
1ce0: 20 20 28 63 6f 6e 63 20 20 28 67 65 74 2d 65 6e (conc (get-en
1cf0: 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 62 vironment-variab
1d00: 6c 65 20 22 44 49 53 50 4c 41 59 22 29 20 22 20 le "DISPLAY") "
1d10: 79 65 73 22 29 0a 09 09 09 20 20 20 20 20 20 22 yes").... "
1d20: 4e 4f 22 29 29 0a 0a 20 20 28 70 72 69 6e 74 20 NO")).. (print
1d30: 22 24 44 49 53 50 4c 41 59 20 61 63 63 65 73 73 "$DISPLAY access
1d40: 69 62 6c 65 3f 20 22 0a 09 20 20 3b 3b 20 28 65 ible? ".. ;; (e
1d50: 71 3f 20 28 73 79 73 74 65 6d 20 22 78 64 70 79 q? (system "xdpy
1d60: 69 6e 66 6f 20 2d 64 69 73 70 6c 61 79 20 24 44 info -display $D
1d70: 49 53 50 4c 41 59 20 26 3e 2f 64 65 76 2f 6e 75 ISPLAY &>/dev/nu
1d80: 6c 6c 22 29 20 30 29 0a 09 20 28 69 66 20 28 63 ll") 0).. (if (c
1d90: 68 65 63 6b 2d 64 69 73 70 6c 61 79 20 28 67 65 heck-display (ge
1da0: 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 t-environment-va
1db0: 72 69 61 62 6c 65 20 22 44 49 53 50 4c 41 59 22 riable "DISPLAY"
1dc0: 29 29 0a 09 20 20 20 20 20 22 79 65 73 22 20 22 )).. "yes" "
1dd0: 4e 4f 22 29 29 0a 0a 20 20 28 70 72 69 6e 74 20 NO")).. (print
1de0: 22 50 61 73 73 77 6f 72 64 2d 6c 65 73 73 20 73 "Password-less s
1df0: 73 68 20 61 63 63 65 73 73 20 74 6f 20 6c 6f 63 sh access to loc
1e00: 61 6c 68 6f 73 74 3a 20 22 0a 09 20 28 69 66 20 alhost: ".. (if
1e10: 20 28 63 6f 6e 66 69 72 6d 2d 73 73 68 2d 61 63 (confirm-ssh-ac
1e20: 63 65 73 73 2d 74 6f 2d 68 6f 73 74 20 22 6c 6f cess-to-host "lo
1e30: 63 61 6c 68 6f 73 74 22 29 0a 09 20 20 20 20 20 calhost")..
1e40: 20 22 79 65 73 22 0a 09 20 20 20 20 20 20 22 4e "yes".. "N
1e50: 4f 22 29 29 0a 0a 20 20 3b 3b 20 69 66 20 49 27 O")).. ;; if I'
1e60: 6d 20 69 6e 20 61 20 4d 65 67 61 74 65 73 74 20 m in a Megatest
1e70: 61 72 65 61 20 64 6f 20 73 6f 6d 65 20 63 68 65 area do some che
1e80: 63 6b 73 0a 20 20 28 70 72 69 6e 74 20 22 48 61 cks. (print "Ha
1e90: 76 65 20 6d 65 67 61 74 65 73 74 2e 63 6f 6e 66 ve megatest.conf
1ea0: 69 67 3a 20 22 0a 09 20 28 69 66 20 28 66 69 6c ig: ".. (if (fil
1eb0: 65 2d 65 78 69 73 74 73 3f 20 22 6d 65 67 61 74 e-exists? "megat
1ec0: 65 73 74 2e 63 6f 6e 66 69 67 22 29 0a 09 20 20 est.config")..
1ed0: 20 20 20 22 79 65 73 22 0a 09 20 20 20 20 20 22 "yes".. "
1ee0: 4e 4f 22 29 29 0a 0a 20 20 28 70 72 69 6e 74 20 NO")).. (print
1ef0: 22 48 61 76 65 20 72 75 6e 63 6f 6e 66 69 67 73 "Have runconfigs
1f00: 2e 63 6f 6e 66 69 67 3a 20 22 0a 09 20 28 69 66 .config: ".. (if
1f10: 20 28 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 22 (file-exists? "
1f20: 72 75 6e 63 6f 6e 66 69 67 73 2e 63 6f 6e 66 69 runconfigs.confi
1f30: 67 22 29 0a 09 20 20 20 20 20 22 79 65 73 22 0a g").. "yes".
1f40: 09 20 20 20 20 20 22 4e 4f 22 29 29 0a 0a 20 20 . "NO"))..
1f50: 28 69 66 20 28 66 69 6c 65 2d 65 78 69 73 74 73 (if (file-exists
1f60: 3f 20 22 2e 68 6f 6d 65 68 6f 73 74 22 29 0a 20 ? ".homehost").
1f70: 20 20 20 20 20 28 6c 65 74 2a 20 28 28 68 6f 6d (let* ((hom
1f80: 65 68 6f 73 74 20 28 77 69 74 68 2d 69 6e 70 75 ehost (with-inpu
1f90: 74 2d 66 72 6f 6d 2d 66 69 6c 65 20 22 2e 68 6f t-from-file ".ho
1fa0: 6d 65 68 6f 73 74 22 0a 09 09 09 20 72 65 61 64 mehost".... read
1fb0: 2d 6c 69 6e 65 29 29 0a 09 20 20 20 20 20 28 63 -line)).. (c
1fc0: 75 72 72 68 6f 73 74 20 28 67 65 74 2d 68 6f 73 urrhost (get-hos
1fd0: 74 2d 6e 61 6d 65 29 29 0a 09 20 20 20 20 20 28 t-name)).. (
1fe0: 62 65 73 74 61 64 72 73 20 28 73 65 72 76 65 72 bestadrs (server
1ff0: 3a 67 65 74 2d 62 65 73 74 2d 67 75 65 73 73 2d :get-best-guess-
2000: 61 64 64 72 65 73 73 20 63 75 72 72 68 6f 73 74 address currhost
2010: 29 29 29 0a 09 28 70 72 69 6e 74 20 22 48 61 76 )))..(print "Hav
2020: 65 20 2e 68 6f 6d 65 68 6f 73 74 20 61 6e 64 20 e .homehost and
2030: 69 74 20 69 73 20 74 68 65 20 6c 6f 63 61 6c 68 it is the localh
2040: 6f 73 74 3a 20 22 0a 09 20 20 20 20 20 20 20 28 ost: ".. (
2050: 69 66 20 28 65 71 75 61 6c 3f 20 68 6f 6d 65 68 if (equal? homeh
2060: 6f 73 74 20 62 65 73 74 61 64 72 73 29 0a 09 09 ost bestadrs)...
2070: 20 20 20 22 79 65 73 22 0a 09 09 20 20 20 28 63 "yes"... (c
2080: 6f 6e 63 20 22 2e 68 6f 6d 65 68 6f 73 74 3d 22 onc ".homehost="
2090: 20 68 6f 6d 65 68 6f 73 74 20 22 2c 20 6c 6f 63 homehost ", loc
20a0: 61 6c 68 6f 73 74 3d 22 20 62 65 73 74 61 64 72 alhost=" bestadr
20b0: 73 20 22 2c 20 4e 4f 22 29 29 29 0a 09 28 70 72 s ", NO")))..(pr
20c0: 69 6e 74 20 22 48 61 76 65 20 2e 68 6f 6d 65 68 int "Have .homeh
20d0: 6f 73 74 20 61 6e 64 20 69 74 20 69 73 20 72 65 ost and it is re
20e0: 61 63 68 61 62 6c 65 20 76 69 61 20 73 73 68 3a achable via ssh:
20f0: 20 22 0a 09 20 20 20 20 20 20 20 28 69 66 20 28 ".. (if (
2100: 63 6f 6e 66 69 72 6d 2d 73 73 68 2d 61 63 63 65 confirm-ssh-acce
2110: 73 73 2d 74 6f 2d 68 6f 73 74 20 68 6f 6d 65 68 ss-to-host homeh
2120: 6f 73 74 29 0a 09 09 20 20 20 22 79 65 73 22 0a ost)... "yes".
2130: 09 09 20 20 20 22 4e 4f 22 29 29 0a 09 29 29 0a .. "NO"))..)).
2140: 0a 20 20 28 69 66 20 28 66 69 6c 65 2d 65 78 69 . (if (file-exi
2150: 73 74 73 3f 20 22 6d 65 67 61 74 65 73 74 2e 63 sts? "megatest.c
2160: 6f 6e 66 69 67 22 29 0a 20 20 20 20 20 20 28 6c onfig"). (l
2170: 65 74 2a 20 28 28 63 64 61 74 20 28 72 65 61 64 et* ((cdat (read
2180: 2d 63 6f 6e 66 69 67 20 22 6d 65 67 61 74 65 73 -config "megates
2190: 74 2e 63 6f 6e 66 69 67 22 20 23 66 20 23 66 29 t.config" #f #f)
21a0: 29 29 0a 09 28 70 72 69 6e 74 20 22 48 61 76 65 ))..(print "Have
21b0: 20 5b 64 69 73 6b 73 5d 20 73 65 63 74 69 6f 6e [disks] section
21c0: 3a 20 22 0a 09 20 20 20 20 20 20 20 28 69 66 20 : ".. (if
21d0: 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f (hash-table-ref/
21e0: 64 65 66 61 75 6c 74 20 63 64 61 74 20 22 64 69 default cdat "di
21f0: 73 6b 73 22 20 23 66 29 0a 09 09 20 20 20 28 63 sks" #f)... (c
2200: 6f 6e 63 20 28 68 61 73 68 2d 74 61 62 6c 65 2d onc (hash-table-
2210: 72 65 66 20 63 64 61 74 20 22 64 69 73 6b 73 22 ref cdat "disks"
2220: 29 20 22 20 79 65 73 22 29 0a 09 09 20 20 20 22 ) " yes")... "
2230: 4e 4f 22 29 29 0a 09 28 66 6f 72 2d 65 61 63 68 NO"))..(for-each
2240: 0a 09 20 28 6c 61 6d 62 64 61 20 28 65 6e 74 72 .. (lambda (entr
2250: 79 29 0a 09 20 20 20 28 6d 61 74 63 68 0a 09 20 y).. (match..
2260: 20 20 20 65 6e 74 72 79 0a 09 20 20 20 20 28 28 entry.. ((
2270: 64 6e 61 6d 65 20 70 61 74 68 29 0a 09 20 20 20 dname path)..
2280: 20 20 28 70 72 69 6e 74 20 22 44 69 73 6b 20 22 (print "Disk "
2290: 20 64 6e 61 6d 65 20 22 20 61 74 20 22 20 70 61 dname " at " pa
22a0: 74 68 20 22 20 77 72 69 74 65 61 62 6c 65 3a 20 th " writeable:
22b0: 22 0a 09 09 20 20 20 20 28 69 66 20 28 63 68 65 "... (if (che
22c0: 63 6b 2d 77 72 69 74 65 2d 63 72 65 61 74 65 20 ck-write-create
22d0: 70 61 74 68 29 20 22 79 65 73 22 20 22 4e 4f 22 path) "yes" "NO"
22e0: 29 29 29 0a 09 20 20 20 20 28 65 6c 73 65 20 28 ))).. (else (
22f0: 70 72 69 6e 74 20 22 62 61 64 20 65 6e 74 72 79 print "bad entry
2300: 3a 20 22 20 65 6e 74 72 79 29 29 29 29 0a 09 20 : " entry))))..
2310: 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f (hash-table-ref/
2320: 64 65 66 61 75 6c 74 20 63 64 61 74 20 22 64 69 default cdat "di
2330: 73 6b 73 22 20 27 28 29 29 29 29 29 0a 0a 20 20 sks" '()))))..
2340: 28 70 72 69 6e 74 20 22 48 61 76 65 20 6c 69 6e (print "Have lin
2350: 6b 20 74 72 65 65 20 61 6e 64 20 69 74 20 69 73 k tree and it is
2360: 20 77 72 69 74 61 62 6c 65 3a 20 22 0a 09 20 28 writable: ".. (
2370: 69 66 20 28 61 6e 64 20 28 66 69 6c 65 2d 65 78 if (and (file-ex
2380: 69 73 74 73 3f 20 22 6c 74 22 29 0a 09 09 20 20 ists? "lt")...
2390: 28 63 68 65 63 6b 2d 77 72 69 74 65 2d 63 72 65 (check-write-cre
23a0: 61 74 65 20 22 6c 74 22 29 29 0a 09 20 20 20 20 ate "lt"))..
23b0: 20 22 79 65 73 22 0a 09 20 20 20 20 20 22 4e 4f "yes".. "NO
23c0: 22 29 29 0a 20 20 3b 3b 20 20 20 20 63 68 65 63 ")). ;; chec
23d0: 6b 20 6c 6f 61 64 20 6f 6e 20 68 6f 6d 65 68 6f k load on homeho
23e0: 73 74 0a 20 20 29 0a 0a 3b 3b 20 44 65 76 65 6c st. )..;; Devel
23f0: 6f 70 20 73 74 75 66 66 20 68 65 72 65 20 2d 20 op stuff here -
2400: 74 68 65 6e 20 6d 6f 76 65 20 74 6f 20 77 68 65 then move to whe
2410: 72 65 20 69 74 20 62 65 6c 6f 6e 67 73 2e 0a 0a re it belongs...
2420: 0a 29 0a .).