pilog.l (15135B)
1 # 19jul13abu 2 # (c) Software Lab. Alexander Burger 3 4 # *Rule 5 6 (de be CL 7 (clause CL) ) 8 9 (de clause (CL) 10 (with (car CL) 11 (if (== *Rule This) 12 (queue (:: T) (cdr CL)) 13 (=: T (cons (cdr CL))) 14 (setq *Rule This) ) 15 This ) ) 16 17 (de repeat () 18 (conc (get *Rule T) (get *Rule T)) ) 19 20 (de asserta (CL) 21 (push (prop CL 1 T) (cdr CL)) ) 22 23 (de assertz (CL) 24 (queue (prop CL 1 T) (cdr CL)) ) 25 26 (de retract (X) 27 (if (sym? X) 28 (put X T) 29 (put (car X) T 30 (delete (cdr X) (get (car X) T)) ) ) ) 31 32 (de rules @ 33 (while (args) 34 (let S (next) 35 (for ((N . L) (get S T) L) 36 (prin N " (be ") 37 (print S) 38 (for X (pop 'L) 39 (space) 40 (print X) ) 41 (prinl ")") 42 (T (== L (get S T)) 43 (println '(repeat)) ) ) 44 S ) ) ) 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 (flush) ) 87 (T (line)) ) ) ) 88 89 (de ? "CL" 90 (let "L" 91 (make 92 (while (nor (pat? (car "CL")) (lst? (car "CL"))) 93 (link (pop '"CL")) ) ) 94 (query (goal "CL") "L") ) ) 95 96 ### Basic Rules ### 97 (be repeat) 98 (repeat) 99 100 (be true) 101 102 (be not @P (1 (-> @P)) T (fail)) 103 (be not @P) 104 105 (be call @P 106 (2 (cons (-> @P))) ) 107 108 (be or @L (^ @C (box (-> @L))) (_or @C)) 109 110 (be _or (@C) (3 (pop (-> @C)))) 111 (be _or (@C) (^ @ (not (val (-> @C)))) T (fail)) 112 (repeat) 113 114 (be nil (@X) (^ @ (not (-> @X)))) 115 116 (be equal (@X @X)) 117 118 (be different (@X @X) T (fail)) 119 (be different (@ @)) 120 121 (be append (NIL @X @X)) 122 (be append ((@A . @X) @Y (@A . @Z)) (append @X @Y @Z)) 123 124 (be member (@X (@X . @))) 125 (be member (@X (@ . @Y)) (member @X @Y)) 126 127 (be delete (@A (@A . @Z) @Z)) 128 (be delete (@A (@X . @Y) (@X . @Z)) 129 (delete @A @Y @Z) ) 130 131 (be permute ((@X) (@X))) 132 (be permute (@L (@X . @Y)) 133 (delete @X @L @D) 134 (permute @D @Y) ) 135 136 (be uniq (@B @X) 137 (^ @ (not (idx (-> @B) (-> @X) T))) ) 138 139 (be asserta (@C) (^ @ (asserta (-> @C)))) 140 141 (be assertz (@C) (^ @ (assertz (-> @C)))) 142 143 (be retract (@C) 144 (2 (cons (-> @C))) 145 (^ @ (retract (list (car (-> @C)) (cdr (-> @C))))) ) 146 147 (be clause ("@H" "@B") 148 (^ "@A" (get (-> "@H") T)) 149 (member "@B" "@A") ) 150 151 (be show (@X) (^ @ (show (-> @X)))) 152 153 (be for (@N @End) (for @N 1 @End 1)) 154 (be for (@N @Beg @End) (for @N @Beg @End 1)) 155 (be for (@N @Beg @End @Step) (equal @N @Beg)) 156 (be for (@N @Beg @End @Step) 157 (^ @I (box (-> @Beg))) 158 (_for @N @I @End @Step) ) 159 160 (be _for (@N @I @End @Step) 161 (^ @ 162 (if (>= (-> @End) (val (-> @I))) 163 (> (inc (-> @I) (-> @Step)) (-> @End)) 164 (> (-> @End) (dec (-> @I) (-> @Step))) ) ) 165 T 166 (fail) ) 167 168 (be _for (@N @I @End @Step) 169 (^ @N (val (-> @I))) ) 170 171 (repeat) 172 173 ### DB ### 174 (de initQuery (Var Cls Hook Val) 175 (let (Tree (tree Var Cls Hook) Rel (get Cls Var)) 176 (when (find '((B) (isa '+index B)) (get Rel 'bag)) 177 (setq Rel @) ) 178 (cond 179 ((pair Val) 180 (cond 181 ((pair (cdr Val)) 182 (cond 183 ((not (; Rel aux)) (quit "No Aux")) 184 ((atom (car Val)) 185 (and (; Rel ub) (setq Val (ubZval Val))) 186 (init Tree Val (append Val T)) ) 187 ((; Rel ub) 188 (init Tree 189 (ubZval (mapcar car Val)) 190 (ubZval (mapcar cdr Val) T) ) ) 191 ((>= (cdr Val) (car Val)) 192 (init Tree (car Val) (append (cdr Val) T)) ) 193 (T (init Tree (append (car Val) T) (cdr Val))) ) ) 194 ((isa '+Key Rel) 195 (init Tree (car Val) (cdr Val)) ) 196 ((>= (cdr Val) (car Val)) 197 (init Tree 198 (cons (car Val)) 199 (cons (cdr Val) T) ) ) 200 (T 201 (init Tree 202 (cons (car Val) T) 203 (cons (cdr Val)) ) ) ) ) 204 ((or (num? Val) (ext? Val)) 205 (if (isa '+Key Rel) 206 (init Tree Val Val) 207 (init Tree (cons Val) (cons Val T)) ) ) 208 ((=T Val) (init Tree)) 209 ((isa '+Key Rel) 210 (init Tree Val (pack Val `(char T))) ) 211 ((isa '+Idx Rel) 212 (let Q (init Tree (cons Val) (cons (pack Val `(char T)) T)) 213 (if (cdr Q) 214 Q 215 (setq Val (pack (car (split (chop Val) " ")))) 216 (init Tree (cons Val) (cons (pack Val `(char T)) T)) ) ) ) 217 (T (init Tree (cons Val) (cons (pack Val `(char T)) T))) ) ) ) 218 219 # (db var cls obj) 220 (be db (@Var @Cls @Obj) 221 (^ @Q 222 (box 223 (with (or (get (-> @Cls) (-> @Var)) (meta (-> @Cls) (-> @Var))) 224 (initQuery (: var) (: cls) NIL '(NIL . T)) ) ) ) 225 (_db @Obj) ) 226 227 # (db var cls hook|val obj) 228 (be db (@Var @Cls @X @Obj) 229 (^ @Q 230 (box 231 (with (or (get (-> @Cls) (-> @Var)) (meta (-> @Cls) (-> @Var))) 232 (cond 233 ((: hook) 234 (initQuery (: var) (: cls) (-> @X) '(NIL . T)) ) 235 ((isa '+Fold This) 236 (initQuery (: var) (: cls) NIL (fold (-> @X))) ) 237 (T 238 (initQuery (: var) (: cls) NIL (-> @X)) ) ) ) ) ) 239 (_db @Obj) ) 240 241 # (db var cls hook val obj) 242 (be db (@Var @Cls @Hook @Val @Obj) 243 (^ @Q 244 (box 245 (with (or (get (-> @Cls) (-> @Var)) (meta (-> @Cls) (-> @Var))) 246 (initQuery (: var) (: cls) (-> @Hook) 247 (if (isa '+Fold This) 248 (fold (-> @Val)) 249 (-> @Val) ) ) ) ) ) 250 (_db @Obj) ) 251 252 (be _db (@Obj) 253 (^ @ 254 (let (Q (val (-> @Q 2)) Cls (-> @Cls 2)) 255 (loop 256 (NIL (step Q (= '(NIL) (caaar Q))) T) 257 (T (isa Cls (setq "R" @))) ) ) ) 258 T 259 (fail) ) 260 261 (be _db (@Obj) (^ @Obj "R")) 262 263 (repeat) 264 265 266 (be val (@V . @L) 267 (^ @V (apply get (-> @L))) 268 T ) 269 270 (be lst (@V . @L) 271 (^ @Lst (box (apply get (-> @L)))) 272 (_lst @V @Lst) ) 273 274 (be _lst (@Val @Lst) (^ @ (not (val (-> @Lst)))) T (fail)) 275 (be _lst (@Val @Lst) (^ @Val (pop (-> @Lst)))) 276 (repeat) 277 278 (be map (@V . @L) 279 (^ @Lst (box (apply get (-> @L)))) 280 (_map @V @Lst) ) 281 282 (be _map (@Val @Lst) (^ @ (not (val (-> @Lst)))) T (fail)) 283 (be _map (@Val @Lst) (^ @Val (prog1 (val (-> @Lst)) (pop (-> @Lst))))) 284 (repeat) 285 286 287 (be isa (@Typ . @L) 288 (^ @ 289 (or 290 (not (-> @Typ)) 291 (isa (-> @Typ) (apply get (-> @L))) ) ) ) 292 293 (be same (@V . @L) 294 (^ @ 295 (let V (-> @V) 296 (or 297 (not V) 298 (let L (-> @L) 299 ("same" (car L) (cdr L)) ) ) ) ) ) 300 301 (de "same" (X L) 302 (cond 303 ((not L) 304 (if (atom X) 305 (= V X) 306 (member V X) ) ) 307 ((atom X) 308 ("same" (get X (car L)) (cdr L)) ) 309 ((atom (car L)) 310 (pick 311 '((Y) ("same" (get Y (car L)) (cdr L))) 312 X ) ) 313 (T ("same" (apply get (car L) X) (cdr L))) ) ) 314 315 (be bool (@F . @L) 316 (^ @ 317 (or 318 (not (-> @F)) 319 (apply get (-> @L)) ) ) ) 320 321 (be range (@N . @L) 322 (^ @ 323 (let N (-> @N) 324 (or 325 (not N) 326 (let L (-> @L) 327 ("range" (car L) (cdr L)) ) ) ) ) ) 328 329 (de "range" (X L) 330 (cond 331 ((not L) 332 (if (atom X) 333 (or 334 (<= (car N) X (cdr N)) 335 (>= (car N) X (cdr N)) ) 336 (find 337 '((Y) 338 (or 339 (<= (car N) Y (cdr N)) 340 (>= (car N) Y (cdr N)) ) ) 341 X ) ) ) 342 ((atom X) 343 ("range" (get X (car L)) (cdr L)) ) 344 ((atom (car L)) 345 (pick 346 '((Y) ("range" (get Y (car L)) (cdr L))) 347 X ) ) 348 (T ("range" (apply get (car L) X) (cdr L))) ) ) 349 350 (be head (@S . @L) 351 (^ @ 352 (let S (-> @S) 353 (or 354 (not S) 355 (let L (-> @L) 356 ("head" (car L) (cdr L)) ) ) ) ) ) 357 358 (de "head" (X L) 359 (cond 360 ((not L) 361 (if (atom X) 362 (pre? S X) 363 (find '((Y) (pre? S Y)) X) ) ) 364 ((atom X) 365 ("head" (get X (car L)) (cdr L)) ) 366 ((atom (car L)) 367 (pick 368 '((Y) ("head" (get Y (car L)) (cdr L))) 369 X ) ) 370 (T ("head" (apply get (car L) X) (cdr L))) ) ) 371 372 (be fold (@S . @L) 373 (^ @ 374 (let S (-> @S) 375 (or 376 (not S) 377 (let L (-> @L) 378 ("fold" (car L) (cdr L)) ) ) ) ) ) 379 380 (de "fold" (X L) 381 (cond 382 ((not L) 383 (let P (fold S) 384 (if (atom X) 385 (pre? P (fold X)) 386 (find '((Y) (pre? P (fold Y))) X) ) ) ) 387 ((atom X) 388 ("fold" (get X (car L)) (cdr L)) ) 389 ((atom (car L)) 390 (pick 391 '((Y) ("fold" (get Y (car L)) (cdr L))) 392 X ) ) 393 (T ("fold" (apply get (car L) X) (cdr L))) ) ) 394 395 (be part (@S . @L) 396 (^ @ 397 (let S (-> @S) 398 (or 399 (not S) 400 (let L (-> @L) 401 ("part" (car L) (cdr L)) ) ) ) ) ) 402 403 (de "part" (X L) 404 (cond 405 ((not L) 406 (let P (fold S) 407 (if (atom X) 408 (sub? P (fold X)) 409 (find '((Y) (sub? P (fold Y))) X) ) ) ) 410 ((atom X) 411 ("part" (get X (car L)) (cdr L)) ) 412 ((atom (car L)) 413 (pick 414 '((Y) ("part" (get Y (car L)) (cdr L))) 415 X ) ) 416 (T ("part" (apply get (car L) X) (cdr L))) ) ) 417 418 (be tolr (@S . @L) 419 (^ @ 420 (let S (-> @S) 421 (or 422 (not S) 423 (let L (-> @L) 424 ("tolr" (car L) (cdr L)) ) ) ) ) ) 425 426 (de "tolr" (X L) 427 (cond 428 ((not L) 429 (if (atom X) 430 (or (sub? S X) (pre? (ext:Snx S) (ext:Snx X))) 431 (let P (ext:Snx S) 432 (find 433 '((Y) 434 (or (sub? S Y) (pre? P (ext:Snx Y))) ) 435 X ) ) ) ) 436 ((atom X) 437 ("tolr" (get X (car L)) (cdr L)) ) 438 ((atom (car L)) 439 (pick 440 '((Y) ("tolr" (get Y (car L)) (cdr L))) 441 X ) ) 442 (T ("tolr" (apply get (car L) X) (cdr L))) ) ) 443 444 445 (de "select" (Lst Flg) 446 (let? X 447 (nond 448 ((atom (car Lst)) 449 (make 450 (for (L (pop 'Lst) L) 451 (let 452 (Var (pop 'L) 453 Cls (pop 'L) 454 Hook (and (get Cls Var 'hook) (pop 'L)) 455 Val (pop 'L) ) 456 (and (or Val Flg) (chain ("initSel"))) ) ) ) ) 457 ((pat? (car Lst)) 458 (let 459 (Var (pop 'Lst) 460 Cls (pop 'Lst) 461 Hook (and (get Cls Var 'hook) (pop 'Lst)) 462 Val (pop 'Lst) ) 463 (and (or Val Flg) ("initSel")) ) ) 464 (NIL 465 (let (Var (pop 'Lst) Val (pop 'Lst)) 466 (and 467 (or Flg (apply or Val)) 468 (cons Var (goal (pop 'Lst))) ) ) ) ) 469 (cons 470 (cons 471 (for (L NIL Lst) 472 (push 'L (pop 'Lst) NIL) 473 L ) 474 X ) ) ) ) 475 476 (de "initSel" () 477 (with (treeRel Var Cls) 478 (cond 479 ((isa '+Fold This) 480 (initQuery Var (: cls) Hook (fold Val)) ) 481 ((isa '+Sn This) 482 (conc 483 (initQuery Var (: cls) Hook Val) 484 (initQuery Var (: cls) Hook (ext:Snx Val)) ) ) 485 (T (initQuery Var (: cls) Hook Val)) ) ) ) 486 487 (de _gen (Lst Q) 488 (cond 489 (Lst 490 (use X 491 (loop 492 (T 493 (cond 494 ((atom (car Lst)) 495 (prog1 (car Lst) (set Lst)) ) 496 ((atom (caar Lst)) (pop Lst)) 497 (T 498 (prog1 499 (step (car Lst) (= '(NIL) (caar (caar Lst)))) 500 (or (cdaar Lst) (set Lst)) ) ) ) 501 @ ) 502 (NIL (setq X (_gen (cddr Lst) Q))) 503 (set Lst 504 (let Y (cadr Lst) 505 (cond 506 ((atom Y) (get X Y)) 507 ((=T (caddr Y)) 508 (initQuery (car Y) (cadr Y) X (cadddr Y)) ) # X = Hook 509 (T 510 (initQuery 511 (car Y) 512 (cadr Y) 513 (caddr Y) 514 (if (cadddr Y) 515 (cons 516 (cons X (car @)) 517 (cons X (cdr @)) ) 518 X ) ) ) ) ) ) ) ) ) 519 ((pat? (car Q)) (get (prove (cdr Q)) @)) 520 (T (step Q (= '(NIL) (caaar Q)))) ) ) 521 522 (be select (("@Obj" . "@X") . "@Lst") 523 (^ @ (unify (-> "@X"))) 524 (^ "@P" (box (cdr (-> "@Lst")))) 525 (^ "@C" 526 (box # ((obj ..) curr . lst) 527 (let L (car (-> "@Lst")) 528 (setq L 529 (or 530 (mapcan "select" L) 531 ("select" (car L) T) ) ) 532 (cons NIL L L) ) ) ) 533 (_gen "@Obj") 534 (_sel) ) 535 536 (be _gen (@Obj) 537 (^ @ 538 (let C (caadr (val (-> "@C" 2))) 539 (not (setq "*R" (_gen (car C) (cdr C)))) ) ) 540 T 541 (fail) ) 542 543 (be _gen (@Obj) (^ @Obj "*R")) 544 545 (repeat) 546 547 (be _sel () 548 (2 (val (-> "@P" 2))) 549 (^ @ 550 (let C (val (-> "@C" 2)) 551 (unless (idx C "*R" T) 552 (rot (cddr C) (offset (cadr C) (cddr C))) 553 (set (cdr C) (cddr C)) ) ) ) 554 T ) 555 556 (be _sel () 557 (^ @ 558 (let C (cdr (val (-> "@C" 2))) 559 (set C (or (cdar C) (cdr C))) ) ) 560 (fail) ) 561 562 ### Remote queries ### 563 (de rqry Args 564 (for (Q (goal (cdr Args)) (prove Q)) 565 (pr (get @ (car Args))) 566 (NIL (flush)) ) 567 (bye) ) 568 569 (be remote ("@Lst" . "@CL") 570 (^ @Sockets 571 (box 572 (prog1 (cdr (-> "@Lst")) 573 (for X @ # (out . in) 574 ((car X) 575 (cons 'rqry (car (-> "@Lst")) (-> "@CL")) ) ) ) ) ) 576 (^ @ (unify (car (-> "@Lst")))) 577 (_remote "@Lst") ) 578 579 (be _remote ((@Obj . @)) 580 (^ @ (not (val (-> @Sockets 2)))) 581 T 582 (fail) ) 583 584 (be _remote ((@Obj . @)) 585 (^ @Obj 586 (let (Box (-> @Sockets 2) Lst (val Box)) 587 (rot Lst) 588 (loop 589 (T ((cdar Lst)) @) 590 (NIL (set Box (setq Lst (cdr Lst)))) ) ) ) ) 591 592 (repeat) 593 594 ### Debug ### 595 `*Dbg 596 (load "@lib/sq.l") 597 598 # vi:et:ts=3:sw=3