misc.l (1975B)
1 # 16oct07abu 2 # (c) Software Lab. Alexander Burger 3 4 ### Math ### 5 (de accu (Var Key Val) 6 (when Val 7 (if (assoc Key (val Var)) 8 (con @ (+ Val (cdr @))) 9 (push Var (cons Key Val)) ) ) ) 10 11 ### String ### 12 (de align (X . @) 13 (pack 14 (if (pair X) 15 (mapcar 16 '((X) (need X (chop (next)) " ")) 17 X ) 18 (need X (chop (next)) " ") ) ) ) 19 20 ### Number ### 21 (de pad (N Val) 22 (pack (need N (chop Val) "0")) ) 23 24 (de hex (X) 25 (if (num? X) 26 (let L (_hex X) 27 (until (=0 (setq X (>> 4 X))) 28 (push 'L (_hex X)) ) 29 (pack L) ) 30 (let N 0 31 (for C (chop X) 32 (setq C (- (char C) `(char "0"))) 33 (and (> C 9) (dec 'C 7)) 34 (setq N (+ C (>> -4 N))) ) 35 N ) ) ) 36 37 (de _hex (N) 38 (let C (& 15 N) 39 (and (> C 9) (inc 'C 7)) 40 (char (+ C `(char "0"))) ) ) 41 42 ### Tree ### 43 (de balance ("Var" "Lst" "Flg") 44 (unless "Flg" (set "Var")) 45 (let "Len" (length "Lst") 46 (recur ("Lst" "Len") 47 (unless (=0 "Len") 48 (let ("N" (>> 1 (inc "Len")) "L" (nth "Lst" "N")) 49 (idx "Var" (car "L") T) 50 (recurse "Lst" (dec "N")) 51 (recurse (cdr "L") (- "Len" "N")) ) ) ) ) ) 52 53 ### Date ### 54 (de dat$ (Dat C) 55 (when (date Dat) 56 (pack (car @) C (pad 2 (cadr @)) C (pad 2 (caddr @))) ) ) 57 58 (de $dat (S C) 59 (if C 60 (and 61 (= 3 62 (length (setq S (split (chop S) C))) ) 63 (date 64 (format (pack (car S))) # Year 65 (or (format (pack (cadr S))) 0) # Month 66 (or (format (pack (caddr S))) 0) ) ) # Day 67 (and 68 (setq S (format S)) 69 (date 70 (/ S 10000) # Year 71 (% (/ S 100) 100) # Month 72 (% S 100) ) ) ) ) 73 74 ### System ### 75 (de test (Pat . Prg) 76 (bind (fish pat? Pat) 77 (unless (match Pat (run Prg 1)) 78 (msg Prg) 79 (quit 'fail Pat) ) ) ) 80 81 # vi:et:ts=3:sw=3