pilog.l (4411B)
1 # 25jun07abu 2 # (c) Software Lab. Alexander Burger 3 4 # *Rule 5 6 (de be CL 7 (with (car CL) 8 (if (== *Rule This) 9 (=: T (conc (: T) (cons (cdr CL)))) 10 (=: T (cons (cdr CL))) 11 (setq *Rule This) ) 12 This ) ) 13 14 (de repeat () 15 (conc (get *Rule T) (get *Rule T)) ) 16 17 (de asserta (CL) 18 (with (car CL) 19 (=: T (cons (cdr CL) (: T))) ) ) 20 21 (de assertz (CL) 22 (with (car CL) 23 (=: T (conc (: T) (cons (cdr CL)))) ) ) 24 25 (de retract (X) 26 (if (sym? X) 27 (put X T) 28 (put (car X) T 29 (delete (cdr X) (get (car X) T)) ) ) ) 30 31 (de rules @ 32 (while (args) 33 (let S (next) 34 (for ((N . L) (get S T) L) 35 (prin N " (be ") 36 (print S) 37 (for X (pop 'L) 38 (space) 39 (print X) ) 40 (prinl ")") 41 (T (== L (get S T)) 42 (println '(repeat)) ) ) 43 S ) ) ) 44 45 46 ### Pilog Interpreter ### 47 (de goal ("CL" . @) 48 (let Env '(T) 49 (while (args) 50 (push 'Env 51 (cons (cons 0 (next)) 1 (next)) ) ) 52 (while (and "CL" (pat? (car "CL"))) 53 (push 'Env 54 (cons 55 (cons 0 (pop '"CL")) 56 (cons 1 (eval (pop '"CL"))) ) ) ) 57 (cons 58 (cons 59 (conc (list 1 (0) NIL "CL" NIL) Env) ) ) ) ) 60 61 (de fail () 62 (goal '((NIL))) ) 63 64 (de pilog ("CL" . "Prg") 65 (for ("Q" (goal "CL") (prove "Q")) 66 (bind @ (run "Prg")) ) ) 67 68 (de solve ("CL" . "Prg") 69 (make 70 (if "Prg" 71 (for ("Q" (goal "CL") (prove "Q")) 72 (link (bind @ (run "Prg"))) ) 73 (for ("Q" (goal "CL") (prove "Q")) 74 (link @) ) ) ) ) 75 76 (de query ("Q" "Dbg") 77 (use "R" 78 (loop 79 (NIL (prove "Q" "Dbg")) 80 (T (=T (setq "R" @)) T) 81 (for X "R" 82 (space) 83 (print (car X)) 84 (print '=) 85 (print (cdr X)) ) 86 (T (line)) ) ) ) 87 88 (de ? "CL" 89 (let "L" 90 (make 91 (while (nor (pat? (car "CL")) (lst? (car "CL"))) 92 (link (pop '"CL")) ) ) 93 (query (goal "CL") "L") ) ) 94 95 ### Basic Rules ### 96 (be repeat) 97 (repeat) 98 99 (be true) 100 101 (be not @P (1 -> @P) T (fail)) 102 (be not @P) 103 104 (be call (@P . @L) 105 (2 cons (cons (-> @P) (-> @L))) ) 106 107 (be or @L (@C box (-> @L)) (_or @C)) 108 (be _or (@C) (3 pop (-> @C))) 109 (be _or (@C) (@ not (val (-> @C))) T (fail)) 110 (repeat) 111 112 (be nil (@X) (@ not (-> @X))) 113 (be equal (@X @X)) 114 115 (be different (@X @X) T (fail)) 116 (be different (@ @)) 117 118 (be append (NIL @X @X)) 119 (be append ((@A . @X) @Y (@A . @Z)) (append @X @Y @Z)) 120 121 (be member (@X (@X . @))) 122 (be member (@X (@ . @Y)) (member @X @Y)) 123 124 (be delete (@A (@A . @Z) @Z)) 125 (be delete (@A (@X . @Y) (@X . @Z)) 126 (delete @A @Y @Z) ) 127 128 (be permute ((@X) (@X))) 129 (be permute (@L (@X . @Y)) 130 (delete @X @L @D) 131 (permute @D @Y) ) 132 133 (be uniq (@B @X) 134 (@ not (idx (-> @B) (-> @X) T)) ) 135 136 (be asserta (@C) (@ asserta (-> @C))) 137 (be assertz (@C) (@ assertz (-> @C))) 138 139 (be clause ("@H" "@B") 140 ("@A" get (-> "@H") T) 141 (member "@B" "@A") ) 142 143 (be show (@X) (@ show (-> @X))) 144 145 ### idx ### 146 (be idx (@Idx @Str @Sym) 147 (@Q box 148 (let (Node (val (-> @Idx)) Str (-> @Str) Q) 149 (while Node 150 (if (> Str (car Node)) 151 (setq Node (cddr Node)) 152 (when (pre? Str (car Node)) 153 (push 'Q Node) ) 154 (setq Node (cadr Node)) ) ) 155 (cons Str Q) ) ) 156 (_idx @Sym @Q) ) 157 158 (be _idx (@Sym @Q) 159 (@ not 160 (setq "R" 161 (let (Q (val (-> @Q)) Val (cadr Q) Node (cddr Val)) 162 (con Q (cddr Q)) 163 (when Node 164 (loop 165 (T (> (car Q) (car Node))) 166 (when (pre? (car Q) (car Node)) 167 (con Q (cons Node (cdr Q))) ) 168 (NIL (setq Node (cadr Node))) ) ) 169 (car Val) ) ) ) 170 T 171 (fail) ) 172 173 (be _idx (@Sym @Q) (@Sym . "R")) 174 175 (repeat) 176 177 178 (be val (@V . @L) 179 (@V let L (-> @L) 180 (apply get (cdr L) (car L)) ) 181 T ) 182 183 (be lst (@V . @L) 184 (@Lst box 185 (let L (-> @L) 186 (apply get (cdr L) (car L)) ) ) 187 (_lst @V @Lst) ) 188 189 (be _lst (@Val @Lst) (@ not (val (-> @Lst))) T (fail)) 190 (be _lst (@Val @Lst) (@Val pop (-> @Lst))) 191 (repeat) 192 193 (be map (@V . @L) 194 (@Lst box 195 (let L (-> @L) 196 (apply get (cdr L) (car L)) ) ) 197 (_map @V @Lst) ) 198 199 (be _map (@Val @Lst) (@ not (val (-> @Lst))) T (fail)) 200 (be _map (@Val @Lst) (@Val prog1 (val (-> @Lst)) (pop (-> @Lst)))) 201 (repeat) 202 203 # vi:et:ts=3:sw=3