db.l (28330B)
1 # 30may13abu 2 # (c) Software Lab. Alexander Burger 3 4 # *Dbs *Jnl *Blob upd 5 6 ### DB Sizes ### 7 (de dbs Lst 8 (default *Dbs (_dbs 1)) ) 9 10 (de dbs+ (N . Lst) 11 (unless (cdr (nth *Dbs N)) 12 (conc *Dbs (_dbs N)) ) ) 13 14 (de _dbs (N) 15 (mapcar 16 '((L) 17 (let Dbf (cons N (>> (- (car L)) 64)) 18 (for Cls (cdr L) 19 (if (atom Cls) 20 (put Cls 'Dbf Dbf) 21 (for Var (cdr Cls) 22 (unless (get Cls 1 Var) 23 (quit "Bad relation" (cons Var (car Cls))) ) 24 (put (get (car Cls) Var) 'dbf Dbf) ) ) ) ) 25 (inc 'N) 26 (car L) ) 27 Lst ) ) 28 29 (de db: Typ 30 (or (meta Typ 'Dbf 1) 1) ) 31 32 33 ### Tree Access ### 34 (de tree (Var Cls Hook) 35 (cons Var 36 (if Hook 37 (cons Cls Hook) 38 Cls ) ) ) 39 40 (de treeRel (Var Cls) 41 (with (or (get Cls Var) (meta Cls Var)) 42 (or 43 (find '((B) (isa '+index B)) (: bag)) 44 This ) ) ) 45 46 # (db 'var 'cls ['hook] 'any ['var 'any ..]) -> sym 47 (de db (Var Cls . @) 48 (with (treeRel Var Cls) 49 (let (Tree (tree (: var) (: cls) (and (: hook) (next))) Val (next)) 50 (if (isa '+Key This) 51 (if (args) 52 (and (fetch Tree Val) (pass _db @)) 53 (fetch Tree Val) ) 54 (let Key (cons (if (isa '+Fold This) (fold Val) Val)) 55 (let? A (: aux) 56 (while (and (args) (== (pop 'A) (arg 1))) 57 (next) 58 (queue 'Key (next)) ) 59 (and (: ub) (setq Key (ubZval Key))) ) 60 (let Q (init Tree Key (append Key T)) 61 (loop 62 (NIL (step Q T)) 63 (T (pass _db @ Var Val) @) ) ) ) ) ) ) ) 64 65 (de _db (Obj . @) 66 (when (isa Cls Obj) 67 (loop 68 (NIL (next) Obj) 69 (NIL (has> Obj (arg) (next))) ) ) ) 70 71 72 # (aux 'var 'cls ['hook] 'any ..) -> sym 73 (de aux (Var Cls . @) 74 (with (treeRel Var Cls) 75 (let Key (if (: ub) (ubZval (rest)) (rest)) 76 (step 77 (init (tree (: var) (: cls) (and (: hook) (next))) 78 Key 79 (append Key T) ) ) ) ) ) 80 81 82 # (collect 'var 'cls ['hook] ['any|beg ['end [var ..]]]) -> lst 83 (de collect (Var Cls . @) 84 (with (treeRel Var Cls) 85 (let 86 (Tree (tree (: var) (: cls) (and (: hook) (next))) 87 X1 (next) 88 X2 (if (args) (next) (or X1 T)) ) 89 (make 90 (if (isa '+Key This) 91 (iter Tree 92 '((X) (and (isa Cls X) (link (pass get X)))) 93 X1 X2 ) 94 (when (isa '+Fold This) 95 (setq X1 (fold X1) X2 (or (=T X2) (fold X2))) ) 96 (if (>= X2 X1) 97 (if (pair X1) 98 (setq X2 (append X2 T)) 99 (setq X1 (cons X1) X2 (cons X2 T)) ) 100 (if (pair X1) 101 (setq X1 (append X1 T)) 102 (setq X1 (cons X1 T) X2 (cons X2)) ) ) 103 (if (isa '+Idx This) 104 (iter Tree 105 '((X) 106 (and 107 (isa Cls X) 108 (not (memq (setq X (pass get X)) (made))) 109 (link X) ) ) 110 X1 X2 T ) 111 (iter Tree 112 '((X) 113 (and (isa Cls X) (link (pass get X))) ) 114 X1 X2 ) ) ) ) ) ) ) 115 116 117 (de genKey (Var Cls Hook Min Max) 118 (if (lt0 Max) 119 (let K (minKey (tree Var Cls Hook) Min Max) 120 (if (lt0 K) (dec K) (or Max -1)) ) 121 (let K (maxKey (tree Var Cls Hook) Min Max) 122 (if (gt0 K) (inc K) (or Min 1)) ) ) ) 123 124 (de useKey (Var Cls Hook) 125 (let (Tree (tree Var Cls Hook) Max (* 2 (inc (count Tree))) N) 126 (while (fetch Tree (setq N (rand 1 Max)))) 127 N ) ) 128 129 (de genStrKey (Str Var Cls Hook) 130 (while (fetch (tree Var Cls Hook) Str) 131 (setq Str (pack "# " Str)) ) 132 Str ) 133 134 135 ### Relations ### 136 (class +relation) 137 # cls var 138 139 (dm T (Var Lst) 140 (=: cls *Class) 141 (=: var Var) ) 142 143 # Type check 144 (dm mis> (Val Obj)) #> lst 145 (dm ele> (Val)) 146 147 # Value present? 148 (dm has> (Val X) #> any | NIL 149 (and (= Val X) X) ) 150 151 # Set value 152 (dm put> (Obj Old New) 153 New ) 154 155 # Delete value 156 (dm del> (Obj Old Val) 157 (and (<> Old Val) Val) ) 158 159 # Maintain relations 160 (dm rel> (Obj Old New)) 161 162 (dm lose> (Obj Val)) 163 164 (dm keep> (Obj Val)) 165 166 # Finalizer 167 (dm zap> (Obj Val)) 168 169 170 (class +Any +relation) 171 172 173 # (+Bag) (cls ..) (..) (..) 174 (class +Bag +relation) 175 # bag 176 177 (dm T (Var Lst) 178 (=: bag 179 (mapcar 180 '((L) 181 (prog1 182 (new (car L) Var (cdr L)) 183 (and (get @ 'hook) (=: hook T)) ) ) 184 Lst ) ) 185 (super Var) ) 186 187 (dm mis> (Val Obj) 188 (or 189 (ifn (lst? Val) "Not a Bag") 190 (pick 191 '((This V) 192 (mis> This V Obj 193 (get 194 (if (sym? (: hook)) Obj Val) 195 (: hook) ) ) ) 196 (: bag) 197 Val ) ) ) 198 199 (dm ele> (Val) 200 (and Val 201 (or 202 (atom Val) 203 (find 'ele> (: bag) Val) ) ) ) 204 205 (dm has> (Val X) 206 (and Val 207 (or 208 (super Val X) 209 (pick 'has> (: bag) (circ Val) X) ) ) ) 210 211 (dm put> (Obj Old New) 212 (trim 213 (mapcar 214 '((X O N) (put> X Obj O N)) 215 (: bag) 216 Old 217 New ) ) ) 218 219 (dm rel> (Obj Old New) 220 (when Old 221 (mapc 222 '((This O) 223 (rel> This Obj O NIL 224 (get 225 (if (sym? (: hook)) Obj Old) 226 (: hook) ) ) ) 227 (: bag) 228 Old ) ) 229 (when New 230 (mapc 231 '((This N) 232 (rel> This Obj NIL N 233 (get 234 (if (sym? (: hook)) Obj New) 235 (: hook) ) ) ) 236 (: bag) 237 New ) ) ) 238 239 (dm lose> (Obj Val) 240 (mapc 241 '((This V) 242 (lose> This Obj V 243 (get 244 (if (sym? (: hook)) Obj Val) 245 (: hook) ) ) ) 246 (: bag) 247 Val ) ) 248 249 (dm keep> (Obj Val) 250 (mapc 251 '((This V) 252 (keep> This Obj V 253 (get 254 (if (sym? (: hook)) Obj Val) 255 (: hook) ) ) ) 256 (: bag) 257 Val ) ) 258 259 260 (class +Bool +relation) 261 262 (dm mis> (Val Obj) 263 (and Val (nT Val) ,"Boolean input expected") ) 264 265 266 # (+Number) [num] 267 (class +Number +relation) 268 # scl 269 270 (dm T (Var Lst) 271 (=: scl (car Lst)) 272 (super Var (cdr Lst)) ) 273 274 (dm mis> (Val Obj) 275 (and Val (not (num? Val)) ,"Numeric input expected") ) 276 277 278 # (+Date) 279 (class +Date +Number) 280 281 (dm T (Var Lst) 282 (super Var (cons NIL Lst)) ) 283 284 285 # (+Time) 286 (class +Time +Number) 287 288 (dm T (Var Lst) 289 (super Var (cons NIL Lst)) ) 290 291 292 # (+Symbol) 293 (class +Symbol +relation) 294 295 (dm mis> (Val Obj) 296 (unless (sym? Val) 297 ,"Symbolic type expected" ) ) 298 299 300 # (+String) 301 (class +String +Symbol) 302 303 (dm mis> (Val Obj) 304 (and Val (not (str? Val)) ,"String type expected") ) 305 306 307 # (+Link) typ 308 (class +Link +relation) 309 # type 310 311 (dm T (Var Lst) 312 (unless (=: type (car Lst)) 313 (quit "No Link" Var) ) 314 (super Var (cdr Lst)) ) 315 316 (de canQuery (Val) 317 (and 318 (pair Val) 319 (pair (car Val)) 320 (not 321 (find 322 '((L) 323 (not 324 (find 325 '((Cls) 326 (get 327 Cls 328 ((if (lst? (car L)) cadr car) L) ) ) 329 (: type) ) ) ) 330 Val ) ) ) ) 331 332 (dm mis> (Val Obj) 333 (and 334 Val 335 (nor 336 (isa (: type) Val) 337 (canQuery Val) ) 338 ,"Type error" ) ) 339 340 341 # (+Joint) var typ 342 (class +Joint +Link) 343 # slot 344 345 (dm T (Var Lst) 346 (=: slot (car Lst)) 347 (super Var (cdr Lst)) ) 348 349 (dm mis> (Val Obj) 350 (and 351 Val 352 (nor 353 (canQuery Val) 354 (and 355 (isa (: type) Val) 356 (with (meta Val (: slot)) 357 (or 358 (isa '+Joint This) 359 (find 360 '((B) (isa '+Joint B)) 361 (: bag) ) ) ) ) ) 362 ,"Type error" ) ) 363 364 (dm rel> (Obj Old New) 365 (and Old (del> Old (: slot) Obj)) 366 (and New 367 (not (get Obj T)) 368 (put> New (: slot) Obj) ) ) 369 370 (dm lose> (Obj Val) 371 (when Val 372 (put Val (: slot) 373 (del> (meta Val (: slot)) Obj (get Val (: slot)) Obj) ) ) ) 374 375 (dm keep> (Obj Val) 376 (when Val 377 (put Val (: slot) 378 (put> (meta Val (: slot)) Obj (get Val (: slot)) Obj) ) ) ) 379 380 381 # +Link or +Joint prefix 382 (class +Hook) 383 384 (dm rel> (Obj Old New Hook) 385 (let L 386 (extract 387 '((X) 388 (and (atom X) (setq X (cons T X))) 389 (and 390 (or 391 (== (: var) (meta Obj (cdr X) 'hook)) 392 (find 393 '((B) (== (: var) (get B 'hook))) 394 (meta Obj (cdr X) 'bag) ) ) 395 X ) ) 396 (getl Obj) ) 397 (for X L 398 (rel> (meta Obj (cdr X)) Obj (car X) NIL (or Old *DB)) 399 (rel> (meta Obj (cdr X)) Obj NIL (car X) (or New *DB)) ) ) 400 (extra Obj Old New Hook) ) 401 402 403 # +Index prefix 404 (class +Hook2) 405 406 (dm rel> (Obj Old New Hook) 407 (extra Obj Old New *DB) 408 (when (or (and Hook (n== Hook *DB)) (get Obj (: hook))) 409 (extra Obj Old New Hook) ) ) 410 411 (dm lose> (Obj Val Hook) 412 (extra Obj Val *DB) 413 (when (or (and Hook (n== Hook *DB)) (get Obj (: hook))) 414 (extra Obj Val Hook) ) ) 415 416 (dm keep> (Obj Val Hook) 417 (extra Obj Val *DB) 418 (when (or (and Hook (n== Hook *DB)) (get Obj (: hook))) 419 (extra Obj Val Hook) ) ) 420 421 422 # (+Blob) 423 (class +Blob +relation) 424 425 (de blob (Obj Var) 426 (pack *Blob (glue "/" (chop Obj)) "." Var) ) 427 428 (dm put> (Obj Old New) 429 (and 430 New 431 (dirname (blob Obj)) 432 (call 'mkdir "-p" @) ) 433 (if (flg? New) 434 New 435 (in New (out (blob Obj (: var)) (echo))) 436 T ) ) 437 438 (dm zap> (Obj Val) 439 (and Val (call 'rm "-f" (blob Obj (: var)))) ) 440 441 442 ### Index classes ### 443 (class +index) 444 # hook dbf 445 446 (dm T (Var Lst) 447 (=: hook (car Lst)) 448 (extra Var (cdr Lst)) ) 449 450 451 # (+Key +relation) [hook] 452 (class +Key +index) 453 454 (dm mis> (Val Obj Hook) 455 (or 456 (extra Val Obj Hook) 457 (and 458 Val 459 (not (has> Obj (: var) Val)) 460 (fetch 461 (tree (: var) (: cls) (or Hook (get Obj (: hook)))) 462 Val ) 463 ,"Not unique" ) ) ) 464 465 (dm rel> (Obj Old New Hook) 466 (let Tree (tree (: var) (: cls) (or Hook (get Obj (: hook)))) 467 (and Old 468 (= Obj (fetch Tree Old)) 469 (store Tree Old NIL (: dbf)) ) 470 (and New 471 (not (get Obj T)) 472 (not (fetch Tree New)) 473 (store Tree New Obj (: dbf)) ) ) 474 (extra Obj Old New Hook) ) 475 476 (dm lose> (Obj Val Hook) 477 (store 478 (tree (: var) (: cls) (or Hook (get Obj (: hook)))) 479 Val NIL (: dbf) ) 480 (extra Obj Val Hook) ) 481 482 (dm keep> (Obj Val Hook) 483 (store 484 (tree (: var) (: cls) (or Hook (get Obj (: hook)))) 485 Val Obj (: dbf) ) 486 (extra Obj Val Hook) ) 487 488 489 # (+Ref +relation) [hook] 490 (class +Ref +index) 491 # aux ub 492 493 (dm rel> (Obj Old New Hook) 494 (let 495 (Tree (tree (: var) (: cls) (or Hook (get Obj (: hook)))) 496 Aux (mapcar '((S) (get Obj S)) (: aux)) ) 497 (when Old 498 (let Key (cons Old Aux) 499 (store Tree 500 (if (: ub) 501 (ubZval Key Obj) 502 (append Key Obj) ) 503 NIL 504 (: dbf) ) ) ) 505 (and New 506 (not (get Obj T)) 507 (let Key (cons New Aux) 508 (store Tree 509 (if (: ub) 510 (ubZval Key Obj) 511 (conc Key Obj) ) 512 Obj 513 (: dbf) ) ) ) ) 514 (extra Obj Old New Hook) ) 515 516 (dm lose> (Obj Val Hook) 517 (let Key (cons Val (mapcar '((S) (get Obj S)) (: aux))) 518 (store 519 (tree (: var) (: cls) (or Hook (get Obj (: hook)))) 520 (if (: ub) 521 (ubZval Key Obj) 522 (conc Key Obj) ) 523 NIL 524 (: dbf) ) ) 525 (extra Obj Val Hook) ) 526 527 (dm keep> (Obj Val Hook) 528 (let Key (cons Val (mapcar '((S) (get Obj S)) (: aux))) 529 (store 530 (tree (: var) (: cls) (or Hook (get Obj (: hook)))) 531 (if (: ub) 532 (ubZval Key Obj) 533 (conc Key Obj) ) 534 Obj 535 (: dbf) ) ) 536 (extra Obj Val Hook) ) 537 538 539 # Backing index prefix 540 (class +Ref2) 541 542 (dm T (Var Lst) 543 (unless (meta *Class Var) 544 (quit "No Ref2" Var) ) 545 (extra Var Lst) ) 546 547 (dm rel> (Obj Old New Hook) 548 (with (meta (: cls) (: var)) 549 (let Tree (tree (: var) (: cls)) 550 (when Old 551 (store Tree (cons Old Obj) NIL (: dbf)) ) 552 (and New 553 (not (get Obj T)) 554 (store Tree (cons New Obj) Obj (: dbf)) ) ) ) 555 (extra Obj Old New Hook) ) 556 557 (dm lose> (Obj Val Hook) 558 (with (meta (: cls) (: var)) 559 (store (tree (: var) (: cls)) (cons Val Obj) NIL (: dbf)) ) 560 (extra Obj Val Hook) ) 561 562 (dm keep> (Obj Val Hook) 563 (with (meta (: cls) (: var)) 564 (store (tree (: var) (: cls)) (cons Val Obj) Obj (: dbf)) ) 565 (extra Obj Val Hook) ) 566 567 568 # (+Idx +relation) [cnt [hook]] 569 (class +Idx +Ref) 570 # min 571 572 (dm T (Var Lst) 573 (=: min (or (car Lst) 3)) 574 (super Var (cdr Lst)) ) 575 576 (de idxRel (Obj Old Olds New News Hook) 577 (let 578 (Tree (tree (: var) (: cls) (or Hook (get Obj (: hook)))) 579 Aux (mapcar '((S) (get Obj S)) (: aux)) 580 Aux2 (append Aux (cons Obj)) ) 581 (setq Aux (conc Aux Obj)) 582 (when Old 583 (store Tree (cons Old Aux) NIL (: dbf)) 584 (for S Olds 585 (while (nth S (: min)) 586 (store Tree (cons (pack S) Aux2) NIL (: dbf)) 587 (pop 'S) ) ) ) 588 (when (and New (not (get Obj T))) 589 (store Tree (cons New Aux) Obj (: dbf)) 590 (for S News 591 (while (nth S (: min)) 592 (store Tree (cons (pack S) Aux2) Obj (: dbf)) 593 (pop 'S) ) ) ) ) ) 594 595 (dm rel> (Obj Old New Hook) 596 (idxRel Obj 597 Old (split (cdr (chop Old)) " " "^J") 598 New (split (cdr (chop New)) " " "^J") 599 Hook ) 600 (extra Obj Old New Hook) ) 601 602 (dm lose> (Obj Val Hook) 603 (idxRel Obj 604 Val (split (cdr (chop Val)) " " "^J") 605 NIL NIL 606 Hook ) 607 (extra Obj Val Hook) ) 608 609 (dm keep> (Obj Val Hook) 610 (idxRel Obj 611 NIL NIL 612 Val (split (cdr (chop Val)) " " "^J") 613 Hook ) 614 (extra Obj Val Hook) ) 615 616 617 # (+Sn +index) [hook] 618 (class +Sn) 619 620 (dm rel> (Obj Old New Hook) 621 (let Tree (tree (: var) (: cls) (or Hook (get Obj (: hook)))) 622 (when Old 623 (store Tree (cons (ext:Snx Old) Obj T) NIL (: dbf)) ) 624 (and New 625 (not (get Obj T)) 626 (store Tree (cons (ext:Snx New) Obj T) Obj (: dbf)) ) ) 627 (extra Obj Old New Hook) ) 628 629 (dm lose> (Obj Val Hook) 630 (store 631 (tree (: var) (: cls) (or Hook (get Obj (: hook)))) 632 (cons (ext:Snx Val) Obj T) 633 NIL (: dbf) ) 634 (extra Obj Val Hook) ) 635 636 (dm keep> (Obj Val Hook) 637 (store 638 (tree (: var) (: cls) (or Hook (get Obj (: hook)))) 639 (cons (ext:Snx Val) Obj T) 640 Obj (: dbf) ) 641 (extra Obj Val Hook) ) 642 643 644 # (+Fold +index) [hook] 645 (class +Fold) 646 647 (dm has> (Val X) 648 (extra Val 649 (if (= Val (fold Val)) (fold X) X) ) ) 650 651 (dm rel> (Obj Old New Hook) 652 (extra Obj (fold Old) (fold New) Hook) ) 653 654 (dm lose> (Obj Val Hook) 655 (extra Obj (fold Val) Hook) ) 656 657 (dm keep> (Obj Val Hook) 658 (extra Obj (fold Val) Hook) ) 659 660 661 # (+IdxFold +relation) [cnt [hook]] 662 (class +IdxFold +Fold +Ref) 663 664 (dm T (Var Lst) 665 (=: min (or (car Lst) 3)) 666 (super Var (cdr Lst)) ) 667 668 (dm rel> (Obj Old New Hook) 669 (idxRel Obj 670 (fold Old) 671 (extract '((L) (extract fold L)) 672 (split (cdr (chop Old)) " " "^J") ) 673 (fold New) 674 (extract '((L) (extract fold L)) 675 (split (cdr (chop New)) " " "^J") ) 676 Hook ) 677 (extra Obj Old New Hook) ) 678 679 (dm lose> (Obj Val Hook) 680 (idxRel Obj 681 (fold Val) 682 (extract '((L) (extract fold L)) 683 (split (cdr (chop Val)) " " "^J") ) 684 NIL NIL 685 Hook ) 686 (extra Obj Val Hook) ) 687 688 (dm keep> (Obj Val Hook) 689 (idxRel Obj 690 NIL NIL 691 (fold Val) 692 (extract '((L) (extract fold L)) 693 (split (cdr (chop Val)) " " "^J") ) 694 Hook ) 695 (extra Obj Val Hook) ) 696 697 698 # (+Aux) lst 699 (class +Aux) 700 701 (dm T (Var Lst) 702 (=: aux (car Lst)) 703 (with *Class 704 (for A (car Lst) 705 (if (asoq A (: Aux)) 706 (queue '@ Var) 707 (queue (:: Aux) (list A Var)) ) ) ) 708 (extra Var (cdr Lst)) ) 709 710 (de relAux (Obj Var Old Lst) 711 (let New (get Obj Var) 712 (put Obj Var Old) 713 (for A Lst 714 (rel> (meta Obj A) Obj (get Obj A) NIL) ) 715 (put Obj Var New) 716 (for A Lst 717 (rel> (meta Obj A) Obj NIL (get Obj A)) ) ) ) 718 719 720 # UB-Tree (+Aux prefix) 721 (class +UB) 722 723 (dm T (Var Lst) 724 (=: ub T) 725 (extra Var Lst) ) 726 727 (de ubZval (Lst X) 728 (let (Res 0 P 1) 729 (while (find gt0 Lst) 730 (map 731 '((L) 732 (and (bit? 1 (car L)) (setq Res (| Res P))) 733 (setq P (>> -1 P)) 734 (set L (>> 1 (car L))) ) 735 Lst ) ) 736 (cons Res X) ) ) 737 738 739 ### Relation prefix classes ### 740 (class +Dep) 741 # dep 742 743 (dm T (Var Lst) 744 (=: dep (car Lst)) 745 (extra Var (cdr Lst)) ) 746 747 (dm rel> (Obj Old New Hook) 748 (unless New 749 (for Var (: dep) 750 (let? V (get Obj Var) 751 (rel> (meta Obj Var) Obj V 752 (put> (meta Obj Var) Obj V NIL) ) ) ) ) 753 (extra Obj Old New Hook) ) 754 755 756 (class +List) 757 758 (dm mis> (Val Obj) 759 (or 760 (ifn (lst? Val) "Not a List") 761 (pick '((V) (extra V Obj)) Val) ) ) 762 763 (dm ele> (Val) 764 (and Val (or (atom Val) (find extra Val))) ) 765 766 (dm has> (Val X) 767 (and Val 768 (or 769 (extra Val X) 770 (find '((X) (extra Val X)) X) ) ) ) 771 772 (dm put> (Obj Old New) 773 (if (ele> This New) 774 (cons (extra Obj Old New) Old) 775 (mapcar 776 '((N O) (extra Obj O N)) 777 New 778 Old ) ) ) 779 780 (dm del> (Obj Old Val) 781 (and 782 (<> Old Val) 783 (delete Val Old) ) ) 784 785 (dm rel> (Obj Old New Hook) 786 (if (or (ele> This Old) (ele> This New)) 787 (extra Obj Old New Hook) 788 (for O (diff Old New) 789 (extra Obj O NIL Hook) ) 790 (for N New 791 (extra Obj NIL N Hook) ) ) ) 792 793 (dm lose> (Obj Val Hook) 794 (if (ele> This Val) 795 (extra Obj Val Hook) 796 (for V Val 797 (extra Obj V Hook) ) ) ) 798 799 (dm keep> (Obj Val Hook) 800 (if (ele> This Val) 801 (extra Obj Val Hook) 802 (for V Val 803 (extra Obj V Hook) ) ) ) 804 805 806 (class +Need) 807 808 (dm mis> (Val Obj) 809 (ifn Val 810 ,"Input required" 811 (extra Val Obj) ) ) 812 813 814 (class +Mis) 815 # mis 816 817 (dm T (Var Lst) 818 (=: mis (car Lst)) 819 (extra Var (cdr Lst)) ) 820 821 (dm mis> (Val Obj) 822 (or ((: mis) Val Obj) (extra Val Obj)) ) 823 824 825 (class +Alt) 826 827 (dm T (Var Lst) 828 (extra Var (cdr Lst)) 829 (=: cls (car Lst)) ) 830 831 832 (class +Swap) 833 # dbf 834 835 (dm has> (Val X) 836 (or (extra Val X) (extra Val (val X))) ) 837 838 (dm put> (Obj Old New) 839 (prog1 840 (or 841 (ext? (get Obj (: var))) 842 (new (or (: dbf 1) 1)) ) 843 (set @ (extra Obj (val Old) New)) ) ) 844 845 (dm del> (Obj Old Val) 846 (ifn (ext? (get Obj (: var))) 847 (extra Obj Old Val) 848 (set @ (extra Obj (val Old) Val)) 849 @ ) ) 850 851 852 ### Entities ### 853 (class +Entity) 854 855 (var Dbf) 856 (var Aux) 857 858 (de dbSync (Obj) 859 (let *Run NIL 860 (while (lock (or Obj *DB)) 861 (wait 40) ) 862 (sync) ) ) 863 864 (de new! ("Typ" . @) 865 (prog2 866 (dbSync) 867 (pass new (or (meta "Typ" 'Dbf 1) 1) "Typ") 868 (commit 'upd) ) ) 869 870 (de set! (Obj Val) 871 (unless (= Val (val Obj)) 872 (dbSync) 873 (set Obj Val) 874 (commit 'upd) ) 875 Val ) 876 877 (de put! (Obj Var Val) 878 (unless (= Val (get Obj Var)) 879 (dbSync) 880 (put Obj Var Val) 881 (commit 'upd) ) 882 Val ) 883 884 (de inc! (Obj Var Val) 885 (when (num? (get Obj Var)) 886 (dbSync) 887 (prog1 (inc (prop Obj Var) (or Val 1)) 888 (commit 'upd) ) ) ) 889 890 (de blob! (Obj Var File) 891 (put!> Obj Var File) 892 (blob+ Obj Var) 893 File ) 894 895 (de blob+ (Obj Var) 896 (when *Jnl 897 (chdir *Blob 898 (call 'ln "-sf" 899 (pack (glue "/" (chop Obj)) "." Var) 900 (pack (name Obj) "." Var) ) ) ) ) 901 902 (dm T @ 903 (while (args) 904 (cond 905 ((=T (next)) (put This T T)) 906 ((atom (arg)) (put> This (arg) (next))) 907 (T (put> This (car (arg)) (eval (cdr (arg))))) ) ) 908 (upd> This (val This)) ) 909 910 (dm zap> () 911 (for X (getl This) 912 (let V (or (atom X) (pop 'X)) 913 (and (meta This X) (zap> @ This V)) ) ) ) 914 915 (dm url> (Tab)) 916 917 (dm upd> (X Old)) 918 919 (dm has> (Var Val) 920 (or 921 (nor Val (get This Var)) 922 (has> (meta This Var) Val (get This Var)) ) ) 923 924 (dm put> (Var Val) 925 (unless (has> This Var Val) 926 (let Old (get This Var) 927 (rel> (meta This Var) This Old 928 (put This Var (put> (meta This Var) This Old Val)) ) 929 (when (asoq Var (meta This 'Aux)) 930 (relAux This Var Old (cdr @)) ) 931 (upd> This Var Old) ) ) 932 Val ) 933 934 (dm put!> (Var Val) 935 (unless (has> This Var Val) 936 (dbSync) 937 (let Old (get This Var) 938 (rel> (meta This Var) This Old 939 (put This Var (put> (meta This Var) This Old Val)) ) 940 (when (asoq Var (meta This 'Aux)) 941 (relAux This Var Old (cdr @)) ) 942 (upd> This Var Old) 943 (commit 'upd) ) ) 944 Val ) 945 946 (dm del> (Var Val) 947 (when (and Val (has> (meta This Var) Val (get This Var))) 948 (let Old (get This Var) 949 (rel> (meta This Var) This Old 950 (put This Var (del> (meta This Var) This Old @)) ) 951 (when (asoq Var (meta This 'Aux)) 952 (relAux This Var Old (cdr @)) ) 953 (upd> This Var Old) ) ) ) 954 955 (dm del!> (Var Val) 956 (when (and Val (has> (meta This Var) Val (get This Var))) 957 (dbSync) 958 (let Old (get This Var) 959 (rel> (meta This Var) This Old 960 (put This Var (del> (meta This Var) This Old @)) ) 961 (when (asoq Var (meta This 'Aux)) 962 (relAux This Var Old (cdr @)) ) 963 (upd> This Var Old) 964 (commit 'upd) ) ) ) 965 966 (dm inc> (Var Val) 967 (let P (prop This Var) 968 (when (num? (car P)) 969 (let Old @ 970 (rel> (meta This Var) This Old 971 (inc P (or Val 1)) ) 972 (when (asoq Var (meta This 'Aux)) 973 (relAux This Var Old (cdr @)) ) 974 (upd> This Var Old) ) 975 (car P) ) ) ) 976 977 (dm inc!> (Var Val) 978 (when (num? (get This Var)) 979 (dbSync) 980 (let (P (prop This Var) Old (car P)) 981 (rel> (meta This Var) This Old 982 (inc P (or Val 1)) ) 983 (when (asoq Var (meta This 'Aux)) 984 (relAux This Var Old (cdr @)) ) 985 (upd> This Var Old) 986 (commit 'upd) 987 (car P) ) ) ) 988 989 (dm dec> (Var Val) 990 (let P (prop This Var) 991 (when (num? (car P)) 992 (let Old @ 993 (rel> (meta This Var) This Old 994 (dec P (or Val 1)) ) 995 (when (asoq Var (meta This 'Aux)) 996 (relAux This Var Old (cdr @)) ) 997 (upd> This Var Old) ) 998 (car P) ) ) ) 999 1000 (dm dec!> (Var Val) 1001 (when (num? (get This Var)) 1002 (dbSync) 1003 (let (P (prop This Var) Old (car P)) 1004 (rel> (meta This Var) This Old 1005 (dec P (or Val 1)) ) 1006 (when (asoq Var (meta This 'Aux)) 1007 (relAux This Var Old (cdr @)) ) 1008 (upd> This Var Old) 1009 (commit 'upd) 1010 (car P) ) ) ) 1011 1012 (dm mis> (Var Val) 1013 (mis> (meta This Var) Val This) ) 1014 1015 (dm lose1> (Var) 1016 (when (meta This Var) 1017 (lose> @ This (get This Var)) ) ) 1018 1019 (dm lose> (Lst) 1020 (unless (: T) 1021 (for X (getl This) 1022 (let V (or (atom X) (pop 'X)) 1023 (and 1024 (not (memq X Lst)) 1025 (meta This X) 1026 (lose> @ This V) ) ) ) 1027 (=: T T) 1028 (upd> This) ) ) 1029 1030 (dm lose!> () 1031 (dbSync) 1032 (lose> This) 1033 (commit 'upd) ) 1034 1035 (de lose "Prg" 1036 (let "Flg" (: T) 1037 (=: T T) 1038 (run "Prg") 1039 (=: T "Flg") ) ) 1040 1041 (dm keep1> (Var) 1042 (when (meta This Var) 1043 (keep> @ This (get This Var)) ) ) 1044 1045 (dm keep> (Lst) 1046 (when (: T) 1047 (=: T) 1048 (for X (getl This) 1049 (let V (or (atom X) (pop 'X)) 1050 (and 1051 (not (memq X Lst)) 1052 (meta This X) 1053 (keep> @ This V) ) ) ) 1054 (upd> This T) ) ) 1055 1056 (dm keep?> (Lst) 1057 (extract 1058 '((X) 1059 (with (and (pair X) (meta This (cdr X))) 1060 (and 1061 (isa '+Key This) 1062 (fetch (tree (: var) (: cls) (get (up This) (: hook))) (car X)) 1063 (cons (car X) ,"Not unique") ) ) ) 1064 (getl This) ) ) 1065 1066 (dm keep!> () 1067 (dbSync) 1068 (keep> This) 1069 (commit 'upd) ) 1070 1071 (de keep "Prg" 1072 (let "Flg" (: T) 1073 (=: T) 1074 (run "Prg") 1075 (=: T "Flg") ) ) 1076 1077 (dm set> (Val) 1078 (unless (= Val (val This)) 1079 (let L 1080 (extract 1081 '((X) 1082 (pop 'X) 1083 (and 1084 (meta Val X) 1085 (n== @ (meta (val This) X)) 1086 X ) ) 1087 (getl This) ) 1088 (for Var L 1089 (let V (get This Var) 1090 (rel> (meta This Var) This V 1091 (put> (meta This Var) This V NIL) ) ) ) 1092 (xchg This 'Val) 1093 (for Var L 1094 (rel> (meta This Var) This NIL 1095 (put> (meta This Var) This NIL (get This Var)) ) ) ) 1096 (upd> This (val This) Val) ) 1097 (val This) ) 1098 1099 (dm set!> (Val) 1100 (unless (= Val (val This)) 1101 (dbSync) 1102 (let L 1103 (extract 1104 '((X) 1105 (pop 'X) 1106 (and 1107 (meta Val X) 1108 (n== @ (meta (val This) X)) 1109 X ) ) 1110 (getl This) ) 1111 (for Var L 1112 (let V (get This Var) 1113 (rel> (meta This Var) This V 1114 (put> (meta This Var) This V NIL) ) ) ) 1115 (xchg This 'Val) 1116 (for Var L 1117 (rel> (meta This Var) This NIL 1118 (put> (meta This Var) This NIL (get This Var)) ) ) ) 1119 (upd> This (val This) Val) 1120 (commit 'upd) ) 1121 (val This) ) 1122 1123 (dm clone> () 1124 (let Obj (new (or (var: Dbf 1) 1) (val This)) 1125 (for X 1126 (by 1127 '((X) 1128 (nand 1129 (pair X) 1130 (isa '+Hook (meta This (cdr X))) ) ) 1131 sort 1132 (getl This ) ) 1133 (if (atom X) 1134 (ifn (meta This X) 1135 (put Obj X T) 1136 (let Rel @ 1137 (put> Obj X T) 1138 (when (isa '+Blob Rel) 1139 (in (blob This X) 1140 (out (blob Obj X) (echo)) ) ) ) ) 1141 (ifn (meta This (cdr X)) 1142 (put Obj (cdr X) (car X)) 1143 (let Rel @ 1144 (cond 1145 ((find '((B) (isa '+Key B)) (get Rel 'bag)) 1146 (let (K @ H (get K 'hook)) 1147 (put> Obj (cdr X) 1148 (mapcar 1149 '((Lst) 1150 (mapcar 1151 '((B Val) 1152 (if (== B K) 1153 (cloneKey B (cdr X) Val 1154 (get (if (sym? H) This Lst) H) ) 1155 Val ) ) 1156 (get Rel 'bag) 1157 Lst ) ) 1158 (car X) ) ) ) ) 1159 ((isa '+Key Rel) 1160 (put> Obj (cdr X) 1161 (cloneKey Rel (cdr X) (car X) 1162 (get This (get Rel 'hook)) ) ) ) 1163 ((or (not (isa '+Joint Rel)) (isa '+List (meta Obj (cdr X)))) 1164 (put> Obj (cdr X) (car X)) ) ) ) ) ) ) 1165 Obj ) ) 1166 1167 (de cloneKey (Rel Var Val Hook) 1168 (cond 1169 ((isa '+Number Rel) 1170 (genKey Var (get Rel 'cls) Hook) ) 1171 ((isa '+String Rel) 1172 (genStrKey (pack "# " Val) Var (get Rel 'cls) Hook) ) ) ) 1173 1174 (dm clone!> () 1175 (prog2 1176 (dbSync) 1177 (clone> This) 1178 (commit 'upd) ) ) 1179 1180 # Default syncronization function 1181 (de upd Lst 1182 (wipe Lst) ) 1183 1184 1185 ### Utilities ### 1186 # Define object variables as relations 1187 (de rel Lst 1188 (def *Class 1189 (car Lst) 1190 (new (cadr Lst) (car Lst) (cddr Lst)) ) ) 1191 1192 # Find or create object 1193 (de request (Typ Var . @) 1194 (let Dbf (or (meta Typ 'Dbf 1) 1) 1195 (ifn Var 1196 (new Dbf Typ) 1197 (with (meta Typ Var) 1198 (or 1199 (pass db Var (: cls)) 1200 (if (: hook) 1201 (pass new Dbf Typ (: hook) (next) Var) 1202 (pass new Dbf Typ Var) ) ) ) ) ) ) 1203 1204 # Create or update object 1205 (de obj Lst 1206 (let Obj (apply request (pop 'Lst)) 1207 (while Lst 1208 (put> Obj (pop 'Lst) (pop 'Lst)) ) 1209 Obj ) ) 1210 1211 # vi:et:ts=3:sw=3