picolisp

Unnamed repository; edit this file to name it for gitweb.
git clone https://logand.com/git/picolisp.git/
Log | Files | Refs | README | LICENSE

sq.l (3890B)

      1 # 04mar13abu
      2 # (c) Software Lab. Alexander Burger
      3 
      4 # (select [var ..] cls [hook|T] [var val ..])
      5 (de select Lst
      6    (let
      7       (Vars
      8          (make
      9             (until
     10                (or
     11                   (atom Lst)
     12                   (and
     13                      (sym? (car Lst))
     14                      (= `(char "+") (char (car Lst))) ) )
     15                (link (pop 'Lst)) ) )
     16          Cls (pop 'Lst)
     17          Hook (cond
     18             ((ext? (car Lst)) (pop 'Lst))
     19             ((=T (car Lst)) (pop 'Lst) *DB) ) )
     20       (default Lst
     21          (cons
     22             (or
     23                (car Vars)
     24                (and
     25                   (find
     26                      '((X) (isa '(+Need +index) (car X)))
     27                      (getl Cls) )
     28                   (get (car @) 'var) )
     29                (cdr
     30                   (maxi caar
     31                      (getl (get (or Hook *DB) Cls)) ) ) ) ) )
     32       (let Q
     33          (goal
     34             (cons
     35                (make
     36                   (link
     37                      'select
     38                      '(@@)
     39                      (make
     40                         (for (L Lst L)
     41                            (link
     42                               (make
     43                                  (link (pop 'L) Cls)
     44                                  (and Hook (link Hook))
     45                                  (link (if L (pop 'L) '(NIL . T))) ) ) ) ) )
     46                   (while Lst
     47                      (let (Var (pop 'Lst)  Val (if Lst (pop 'Lst) '(NIL . T)))
     48                         (link
     49                            (list
     50                               (cond
     51                                  ((pair Val) 'range)
     52                                  ((or (num? Val) (ext? Val)) 'same)
     53                                  ((=T Val) 'bool)
     54                                  ((isa '(+IdxFold) (get Cls Var)) 'part)
     55                                  ((isa '(+Fold +Idx) (get Cls Var)) 'part)
     56                                  ((isa '+Fold (get Cls Var)) 'fold)
     57                                  ((isa '+Sn (get Cls Var)) 'tolr)
     58                                  (T 'head) )
     59                               Val '@@ Var ) ) ) ) ) ) )
     60          (use Obj
     61             (loop
     62                (NIL (setq Obj (cdr (asoq '@@ (prove Q)))))
     63                (ifn Vars
     64                   (show Obj)
     65                   (for Var Vars
     66                      (cond
     67                         ((pair Var)
     68                            (print (apply get Var Obj)) )
     69                         ((meta Obj Var)
     70                            (print> @ (get Obj Var)) )
     71                         (T (print (get Obj Var))) )
     72                      (space) )
     73                   (print Obj) )
     74                (T (line) Obj) ) ) ) ) )
     75 
     76 (dm (print> . +relation) (Val)
     77    (print Val) )
     78 
     79 (dm (print> . +Number) (Val)
     80    (prin (format Val (: scl))) )
     81 
     82 (dm (print> . +Date) (Val)
     83    (print (datStr Val)) )
     84 
     85 
     86 # (update 'obj ['var])
     87 (de update (Obj Var)
     88    (let *Dbg NIL
     89       (printsp Obj)
     90       (if Var
     91          (_update (get Obj Var) Var)
     92          (set!> Obj
     93             (any (revise (sym (val Obj)))) )
     94          (for X (getl Obj)
     95             (_update (or (atom X) (pop 'X)) X) ) )
     96       Obj ) )
     97 
     98 (de _update (Val Var)
     99    (printsp Var)
    100    (let New
    101       (if (meta Obj Var)
    102          (revise> @ Val)
    103          (any (revise (sym Val))) )
    104       (unless (= New Val)
    105          (if (mis> Obj Var New)
    106             (quit "mismatch" @)
    107             (put!> Obj Var New) ) ) ) )
    108 
    109 
    110 (dm (revise> . +relation) (Val)
    111    (any (revise (sym Val))) )
    112 
    113 (dm (revise> . +Bag) (Lst)
    114    (mapcar
    115       '((V B) (space 6) (revise> B V))
    116       (any (revise (sym Lst)))
    117       (: bag) ) )
    118 
    119 (dm (revise> . +Number) (Val)
    120    (format
    121       (revise (format Val (: scl)))
    122       (: scl) ) )
    123 
    124 (dm (revise> . +Date) (Val)
    125    (expDat
    126       (revise
    127          (datStr Val)
    128          '((S) (list (datStr (expDat S)))) ) ) )
    129 
    130 (dm (revise> . +List) (Val)
    131    (mapcar
    132       '((X) (space 3) (extra X))
    133       (any (revise (sym Val))) ) )