simul.l (5077B)
1 # 06aug13abu 2 # (c) Software Lab. Alexander Burger 3 4 (de permute (Lst) 5 (ifn (cdr Lst) 6 (cons Lst) 7 (mapcan 8 '((X) 9 (mapcar 10 '((Y) (cons X Y)) 11 (permute (delete X Lst)) ) ) 12 Lst ) ) ) 13 14 (de subsets (N Lst) 15 (cond 16 ((=0 N) '(NIL)) 17 ((not Lst)) 18 (T 19 (conc 20 (mapcar 21 '((X) (cons (car Lst) X)) 22 (subsets (dec N) (cdr Lst)) ) 23 (subsets N (cdr Lst)) ) ) ) ) 24 25 (de shuffle (Lst) 26 (by '(NIL (rand)) sort Lst) ) 27 28 (de samples (Cnt Lst) 29 (make 30 (until (=0 Cnt) 31 (when (>= Cnt (rand 1 (length Lst))) 32 (link (car Lst)) 33 (dec 'Cnt) ) 34 (pop 'Lst) ) ) ) 35 36 37 # Genetic Algorithm 38 (de gen ("Pop" "Cond" "Re" "Mu" "Se") 39 (until ("Cond" "Pop") 40 (for ("P" "Pop" "P" (cdr "P")) 41 (set "P" 42 (maxi "Se" # Selection 43 (make 44 (for ("P" "Pop" "P") 45 (rot "P" (rand 1 (length "P"))) 46 (link # Recombination + Mutation 47 ("Mu" ("Re" (pop '"P") (pop '"P"))) ) ) ) ) ) ) ) 48 (maxi "Se" "Pop") ) 49 50 51 # Alpha-Beta tree search 52 (de game ("Flg" "Cnt" "Moves" "Move" "Cost") 53 (let ("Alpha" '(1000000) "Beta" -1000000) 54 (recur ("Flg" "Cnt" "Alpha" "Beta") 55 (let? "Lst" ("Moves" "Flg") 56 (if (=0 (dec '"Cnt")) 57 (loop 58 ("Move" (caar "Lst")) 59 (setq "*Val" (list ("Cost" "Flg") (car "Lst"))) 60 ("Move" (cdar "Lst")) 61 (T (>= "Beta" (car "*Val")) 62 (cons "Beta" (car "Lst") (cdr "Alpha")) ) 63 (when (> (car "Alpha") (car "*Val")) 64 (setq "Alpha" "*Val") ) 65 (NIL (setq "Lst" (cdr "Lst")) "Alpha") ) 66 (setq "Lst" 67 (sort 68 (mapcar 69 '(("Mov") 70 (prog2 71 ("Move" (car "Mov")) 72 (cons ("Cost" "Flg") "Mov") 73 ("Move" (cdr "Mov")) ) ) 74 "Lst" ) ) ) 75 (loop 76 ("Move" (cadar "Lst")) 77 (setq "*Val" 78 (if (recurse (not "Flg") "Cnt" (cons (- "Beta")) (- (car "Alpha"))) 79 (cons (- (car @)) (cdar "Lst") (cdr @)) 80 (list (caar "Lst") (cdar "Lst")) ) ) 81 ("Move" (cddar "Lst")) 82 (T (>= "Beta" (car "*Val")) 83 (cons "Beta" (cdar "Lst") (cdr "Alpha")) ) 84 (when (> (car "Alpha") (car "*Val")) 85 (setq "Alpha" "*Val") ) 86 (NIL (setq "Lst" (cdr "Lst")) "Alpha") ) ) ) ) ) ) 87 88 89 ### Grids ### 90 (de grid (DX DY FX FY) 91 (let Grid 92 (make 93 (for X DX 94 (link 95 (make 96 (for Y DY 97 (link 98 (def 99 (if (> DX 26) 100 (box) 101 (intern (pack (char (+ X 96)) Y)) ) 102 (cons (cons) (cons)) ) ) ) ) ) ) ) 103 (let West (and FX (last Grid)) 104 (for (Lst Grid Lst) 105 (let 106 (Col (pop 'Lst) 107 East (or (car Lst) (and FX (car Grid))) 108 South (and FY (last Col)) ) 109 (for (L Col L) 110 (with (pop 'L) 111 (set (: 0 1) (pop 'West)) # west 112 (con (: 0 1) (pop 'East)) # east 113 (set (: 0 -1) South) # south 114 (con (: 0 -1) # north 115 (or (car L) (and FY (car Col))) ) 116 (setq South This) ) ) 117 (setq West Col) ) ) ) 118 Grid ) ) 119 120 (de west (This) 121 (: 0 1 1) ) 122 123 (de east (This) 124 (: 0 1 -1) ) 125 126 (de south (This) 127 (: 0 -1 1) ) 128 129 (de north (This) 130 (: 0 -1 -1) ) 131 132 (de disp ("Grid" "How" "Fun" "X" "Y" "DX" "DY") 133 (setq "Grid" 134 (if "X" 135 (mapcar 136 '((L) (flip (head "DY" (nth L "Y")))) 137 (head "DX" (nth "Grid" "X")) ) 138 (mapcar reverse "Grid") ) ) 139 (let (N (+ (length (cdar "Grid")) (or "Y" 1)) Sp (length N)) 140 ("border" north) 141 (while (caar "Grid") 142 (prin " " (align Sp N) " " 143 (and "How" (if (and (nT "How") (west (caar "Grid"))) " " '|)) ) 144 (for L "Grid" 145 (prin 146 ("Fun" (car L)) 147 (and "How" (if (and (nT "How") (east (car L))) " " '|)) ) ) 148 (prinl) 149 ("border" south) 150 (map pop "Grid") 151 (dec 'N) ) 152 (unless (> (default "X" 1) 26) 153 (space (inc Sp)) 154 (for @ "Grid" 155 (prin " " (and "How" " ") (char (+ 96 "X"))) 156 (T (> (inc '"X") 26)) ) 157 (prinl) ) ) ) 158 159 (de "border" (Dir) 160 (when "How" 161 (space Sp) 162 (prin " +") 163 (for L "Grid" 164 (prin (if (and (nT "How") (Dir (car L))) " +" "---+")) ) 165 (prinl) ) )