;;; File {phylum}<desrivieres>nlisp>library.3-lisp

; **** 3 - L I S P   L I B R A R Y ****

;;; The 3-LISP library consists of that portion of the 
;;; standard system that is neither primitive nor 
;;; kernel.  Note that none of the procedures defined
;;; in the earlier initialization files may use any
;;; of the procedures defined here.


; (ARG N PAIR): the Nth argument structure of
; the pair PAIR; assumes that the argument structure is
; a rail.

(system-define arg
   (lambda [n pair]
      (nth n (pargs pair))))



; (SOME FUN SEQ): true is FUN is true of some element of SEQ.
; Goes with EVERY.

(system-define some
   (lambda [fun seq]
      (cond [(null seq) $false]
            [(fun (first seq)) $true]
            [$true (some fun (rest seq))])))


   
; (MEMBER E SEQ): true if E is a member of the sequence
; or rail SEQ.

(system-define member
   (lambda [e seq]
      (some (lambda [x] (= x e)) seq)))



; (VECTOR-CONSTRUCTOR TEMPLATE): either LIST or RCONS,
; depending on whether or not TEMPLATE is abstract or
; structure.

(system-define vector-constructor
   (lambda [template]
      (if (structure template) rcons list)))



; (COPY-VECTOR SEQ): copies the top-level structure of
; the SEQ.

(system-define copy-vector
   (lambda [seq]
      (if (null seq)
          ((vector-constructor seq))
          (cons (first seq)
                (copy-vector (rest seq))))))



; (REVERSE SEQ): sequence of elements of SEQ in reverse order.

(letrec 
  [[reverse-helper
    (lambda [seq accumulator]
       (if (null seq)
           accumulator
           (reverse-helper (rest seq)
              (cons (first seq) accumulator))))]]
  (system-define reverse
     (lambda [seq]
        (reverse-helper seq ((vector-constructor seq))))))



; (INDEX E SEQ): position of E in SEQ; 0 if not found.

(letrec
  [[index-helper
    (lambda [e seq position]
       (cond [(null seq) 0]
             [(= e (first seq)) position]
             [$true
              (index-helper e (rest seq)
                 (1+ position)) ]))]]
  (system-define index
     (lambda [e seq]
        (index-helper e seq 1))))


; (VECTOR E): true only of sequences and rails.

(system-define vector
   (lambda [e]
      (or (sequence e) (rail e))))


; (EXTERNAL E): true only of abstract objects.

(system-define external
   (lambda [e]
      (not (structure e))))


; (REMAINDER N1 N2): remainder after dividing N1 by N2.

(system-define remainder
   (lambda [n1 n2]
      (- n1 (* (/ n1 n2) n2))))



; (NEGATIVE N): true if N < 0.
; (NON-NEGATIVE N): true if N >= 0.
; (POSITIVE N): true if N > 0.
; (ODD N): true if N is odd.
; (EVEN N): true if N is odd.

(system-define negative (lambda [n] (< n 0)))
(system-define non-negative (lambda [n] (>= n 0)))
(system-define positive (lambda [n] (> n 0)))
(system-define even (lambda [n] (zero (remainder n 2))))
(system-define odd (lambda [n] (not (even n))))



; (ABS N): absolute value of N.

(system-define ABS
   (lambda [n]
      (if (negative n) (- 0 n) n)))



; (** N1 N2): N2-fold product of N1 with itself.

(system-define **
  (lambda [n1 n2]
    (cond [(= n2 0) 1]
          [(= n2 1) n1]
          [(< n2 1) (error "exponent must be non-negative" n2)]
          [$true
           (let [[half-n2 (/ n2 2)]]
             (* (** n1 half-n2) (** n1 (- n2 half-n2))))])))






; (RLAMBDA [CALL ENV ESC CONT] B1 ... BN): reflective lambda.


(system-define rlambda    ; rlambda as a macro.
  \(macroify
    (lambda [call]
      (let [[args (pargs call)]]
        (if (and (rail args) (>= (length args) 2)
                 (valid-pattern (first args))
                 (or (atom (first args))
                     (= (length (first args)) 4)))
            '(,^down (,^reflectify (,^lambda .,args)))
            '(,^trap "malformed rlambda" ,call))))))


; (MLAMBDA [CALL] B1 ... BN): reflective lambda.

(system-define mlambda    ; mlambda as a macro.
  \(macroify
    (lambda [call]
      (let [[args (pargs call)]]
        (if (and (rail args) (>= (length args) 2)
                 (valid-pattern (first args))
                 (or (atom (first args))
                     (= (length (first args)) 1)))
            '\(,^macroify (,^lambda . ,args))
            '(,^trap "malformed mlambda" ,call))))))



; (CURRENT-ENVIRONMENT): makes explicit the current environment.

(system-define current-environment
  (rlambda [call env esc cont]
     (let [[args (pargs call)]]
         (if (and (rail args) (null args))
             (cont ^env) 
             (esc "current-environment expects no arguments"
                  call env esc cont call "")))))



; (IGNORE E1 E2 ...): ignores its arguments.

(system-define ignore
  (rlambda [call env esc cont] (cont ''ok)))



; (LETSEQ [[P1 E1] ...] B1 ...): sequential LET.

(system-define letseq
  (mlambda [call]
    (let [[args (pargs call)]]
      (if (and (rail args)
               (>= (length args) 1)
               (rail (first args))
               (every (lambda [x]
                         (and (rail x)
                              (= (length x) 2)
                              (atom (first x))))
                      (first args)))
          (cond [(null (first args))         ; = a BEGIN.
                 (beginify (rest args))]
                [(= (length (first args)) 1) ; = a LET.
                 '(,^let . ,args)]
                [$true                       ; Peel off one variable
                 (let [[remaining-bindings (rest (first args))]
                       [body (rest args)]] 
                   '(,^let [,(first (first args))] 
                       (,^letseq . ,(cons remaining-bindings body))))])
          '(,^trap "malformed letseq" ,call)))))



; (CATCH TAG B1 ...): Scheme-style catch/throw.

(system-define catch
  (rlambda [call env esc cont]
    (let [[args (pargs call)]]
      (if (and (rail args) (>= (length args) 1) (atom (first args)))
          (let [[thrower (lambda [x] ((rlambda ignore (cont ^x))))]]
             (normalize (beginify (rest args))
                (bind (first args) ^thrower env)
                esc cont))
          (esc "malformed catch"
               call env esc cont call "")))))



; (DELAY C): Scheme-style lambda-deferral.

(system-define delay
  (mlambda [call]
    (let [[args (pargs call)]]
       (if (and (rail args) (= (length args) 1))
           '(,^lambda [] ,(first args))
           '(,^trap "malformed delay" ,call)))))




; (FORCE C): forces a previously-DELAYED computation.

(system-define force
  (mlambda [call]
    (let [[args (pargs call)]]
       (if (and (rail args) (= (length args) 1))
           '(,(first args))
           '(,^trap "malformed force" ,call)))))



; (REDUCE PROC ARGS ENV ESC CONT): normalizes a call

(system-define reduce
   (lambda [proc args env esc cont]
      (normalize '(,proc . ,args) env esc cont)))




; (DESIGNATION EXP ENV): full DOWN.

(system-define designation
   (lambda [structure env]
      (normalize structure env
         (lambda [message structure env esc cont datum-1 datum-2]
            (error (string-append "normalization failed: " message)
               structure)) 
         down)))



; (STRING-CONS CH STR): append a character to a string.

(system-define string-cons string-append) ; Cheat!



; (SELECT INDEX [M1 C1...] ...): Like DISPATCH, except Mi normalized.

(letrec 
 [[select-ok
   (lambda [args]
     (and (rail args) (>= (length args) 1)
       (every (lambda [x]
                 (and (rail x) (>= (length x) 1)))
              (rest args))))]
  [expand-select
   (lambda [args]
     (letseq [[index (first args)]
              [new-variable (acons)]
              [new-clauses
                (map (lambda [x]
                       (cond
                          [(= (first x) '$true) x]
                          [(rail (first x))
                           (cons '(,^member ,new-variable ,(first x))
                              (rest x))]
                          [$true          
                           (cons '(,^= ,new-variable ,(first x))
                              (rest x))]))
                     (rest args))]]
             '(,^let [[,new-variable ,index]]
                 (,^cond . ,new-clauses))))]]
  (system-define select
    (mlambda [call]
      (if (select-ok (pargs call))
          (expand-select (pargs call))
          '(,^trap "malformed select" ,call)))))

 

; (DISPATCH INDEX [A1 C1 ...] ...): n-way dispatch on atoms.

(letrec [
 [dispatch-ok
  (lambda [call]
    (let [[args (pargs call)]]
      (and (rail args) (> (length args) 2)  ; Pattern matcher, where are you?
         (every (lambda [x] (and (rail x) (>= (length x) 1))) (rest args))
         (every atom (map first (all-but-last (rest args))))
         (or (atom (first (last args)))
             (= '$true (first (last args)))))))]] 

  (system-define dispatch
    (mlambda [call]
      (let [[args (pargs call)]]
        (if (dispatch-ok call)
         (let [[index (first args)]
               [new-clauses
                (map (lambda [x]
                       (if (atom (first x))
                           (cons ^(first x) (rest x))
                           x))
                     (rest args))]]
           '(,^select . ,(cons index new-clauses)))
         '(,^trap "malformed dispatch" ,call))))))




; (CURRIED-DISPATCH INDEX [M1 C1 ...]): Like DISPATCH, except
; that the head of each clause must be a pair, into which the
; index's surrogate is placed as the first argument.

(letrec 
 [[dispatch-ok
   (lambda [args]
     (and (rail args) (> (length args) 2)
       (every (lambda [x]
                 (and (rail x) (>= (length x) 1)
                      (pair (first x)) (rail (pargs (first x)))
                      (>= (length (pargs (first x))) 1)))
              (rest args))))]
  [expand-dispatch
   (lambda [args]
     (letseq [[index (first args)]
              [new-variable (acons)]
              [new-clauses
                (map (lambda [x]
                       (cons
                         (pcons (pproc (first x)) 
                            (cons new-variable (rest (pargs (first x)))))
                         (rest x)))
                     (rest args))]]
             '(,^let [[,new-variable ,index]]
                 (,^cond . ,new-clauses))))]]
  (system-define curried-dispatch
    (mlambda [call]
      (if (dispatch-ok (pargs call))
          (expand-dispatch (pargs call))
          '(,^trap "malformed curried-dispatch" ,call)))))




; (DO [[V1 I1 N1] ...] [[EX1 RET1 ...] ...] B1 ...): Maclisp-ish DO.

(letrec 
 [[do-ok
   (lambda [args]
     (and (rail args) (>= (length args) 2)
       (rail (first args)) (rail (second args))
       (every (lambda [x] ; [var init next] triples
                 (and (rail x) (= (length x) 3)
                      (atom (first x))))
              (first args))
       (every (lambda [x] ; [exit-test return] doublets
                 (and (rail x) (>= (length x) 2)))
              (second args))))]
  [expand-do
   (lambda [args]
     (letseq  ; Are you really ready for this???
       [[steppers (first args)]
        [terminators (second args)]
        [loop-variables (map first steppers)]
        [initializers (map second steppers)]
        [steppers (map third steppers)]
        [do-bodies (tail 2 args)]
        [loop-name (acons)]
        [last-clause
         '[$true ,(beginify do-bodies)
                 (,loop-name . ,steppers)] ]
        [cond-clause
         '(,^cond .,(append terminators '[,last-clause])) ] 
        [loop-body 
         '(,^lambda ,loop-variables ,cond-clause) ]] 
      '(,^letrec [[,loop-name ,loop-body]]
          (,loop-name .,initializers)) ))]] 
               
  (system-define do
    (mlambda [call]
      (if (do-ok (pargs call))
          (expand-do (pargs call))
          '(,^trap "malformed do" ,call)))))


.,GACHA
.,
z·