mine.l (3204B)
1 # 08feb11abu 2 # (c) Software Lab. Alexander Burger 3 4 (load "@lib/term.l") 5 6 # Spielfeldbelegung: 7 # NIL Verdeckt: Leeres Feld 8 # T Verdeckt: Mine 9 # 0-8 Aufgedeckt, Nachbarminen 10 11 (seed (in "/dev/urandom" (rd 8))) 12 13 # Globale Konstanten 14 (de *Minen . 24) # Anzahl der Minen 15 (de *FeldX . 12) # Feldgroesse X 16 (de *FeldY . 12) # Feldgroesse Y 17 18 (de *NachbarX -1 0 +1 -1 +1 -1 0 +1) 19 (de *NachbarY -1 -1 -1 0 0 +1 +1 +1) 20 21 # Globale Variablen 22 (de *Feld) # Datenbereich des Minenfeldes 23 24 25 # Eine Mine legen 26 (de legeMine () 27 (use (X Y) 28 (while 29 (get *Feld 30 (setq Y (rand 1 *FeldY)) 31 (setq X (rand 1 *FeldX)) ) ) 32 (set (nth *Feld Y X) T) ) ) 33 34 # *Feld anzeigen 35 (de anzeigen (Flg) 36 (let (N 0 Y 0) 37 (for L *Feld 38 (prin (align 2 (inc 'Y)) " ") 39 (for C L 40 (prin 41 " " 42 (cond 43 ((not C) (inc 'N) "-") 44 (Flg C) 45 ((=T C) "-") 46 (T C) ) ) ) 47 (prinl) ) 48 (prin " ") 49 (for C *FeldX 50 (prin " " (char (+ 64 C))) ) 51 (prinl) 52 (prinl "<" N "> ") ) ) 53 54 # Ein Feld ausrechnen 55 (de wertFeld (X Y) 56 (when 57 (=0 58 (set (nth *Feld Y X) 59 (cnt 60 '((DX DY) 61 (=T (get *Feld (+ Y DY) (+ X DX))) ) 62 *NachbarX 63 *NachbarY ) ) ) 64 (mapc 65 '((DX DY) 66 (and 67 (>= *FeldX (inc 'DX X) 1) 68 (>= *FeldY (inc 'DY Y) 1) 69 (not (member (cons DX DY) *Visit)) 70 (push '*Visit (cons DX DY)) 71 (wertFeld DX DY) ) ) 72 *NachbarX 73 *NachbarY ) ) ) 74 75 # Hauptfunktion 76 (de main (N) 77 (when N 78 (setq *Minen N) ) 79 (setq *Feld 80 (make (do *FeldY (link (need *FeldX)))) ) 81 (do *Minen (legeMine)) ) 82 83 (de go () 84 (use (K X Y) 85 (anzeigen) 86 (xtUp (+ 2 *FeldY)) 87 (xtRight 4) 88 (one X Y) 89 (catch NIL 90 (until (= "^[" (setq K (key))) 91 (case K 92 ("j" 93 (unless (= Y *FeldY) 94 (xtDown 1) 95 (inc 'Y) ) ) 96 ("k" 97 (unless (= Y 1) 98 (xtUp 1) 99 (dec 'Y) ) ) 100 ("l" 101 (unless (= X *FeldX) 102 (xtRight 2) 103 (inc 'X) ) ) 104 ("h" 105 (unless (= X 1) 106 (xtLeft 2) 107 (dec 'X) ) ) 108 ((" " "^J" "^M") 109 (xtLeft (+ 2 (* 2 X))) 110 (xtUp (dec Y)) 111 (when (=T (get *Feld Y X)) 112 (anzeigen T) 113 (prinl "*** BUMM ***") 114 (throw) ) 115 (let *Visit NIL 116 (wertFeld X Y) ) 117 (anzeigen) 118 (unless (find '((L) (memq NIL L)) *Feld) 119 (prinl ">>> Gewonnen! <<<") 120 (throw) ) 121 (xtUp (- *FeldY Y -3)) 122 (xtRight (+ 2 (* 2 X))) ) ) ) 123 (xtLeft (+ 2 (* 2 X))) 124 (xtDown (+ 3 (- *FeldY Y))) ) ) ) 125 126 # vi:et:ts=3:sw=3