Language/OS - Multiplatform Resource Library/LANGUAGE OS.iso/lisp/eulisp/feel0_89.lha/Feel/Boot/collect.em

Text File | 1993-07-04 | 12.0 KB | 436 lines

;; Eulisp Module
;; Author: pab
;; File: collect.em
;; Date: Tue Jun 29 16:05:59 1993
;;
;; Project:
;; Description:
;;  Actually, all jap's work.

(defmodule collect
  (init
   extras0
   macros0
   defs
   gens
   telos1
   character
   )
  ()

  ;; the basic collection operations
  (export
   accumulate
   accumulate1
   concatenate
   do
   emptyp
   fill
   map
   size
   sequencep
   collectionp
   )

  ;; not primitive, but it would be odd to omit them
  (export
   member
   reverse
   )


  ;; ones I had to write to make the rest work
  (export
   anyp
   intersection
   )

  ;; imports to be re-exported
  (export
   element
   )

  ;; predicates
  (defpredicate sequencep <sequence>)
  (defpredicate collectionp <collection>)

  ;; converter methods

  (defmethod (converter <list>) ((c <collection>))
    ;; converts any kind of collection to a list
    (let ((r ()))
      (labels
       ((loop (s)
          (if (null s)
          r
        (progn (setq r (cons (current-element c s) r))
               (loop (previous-state c s))))))
       (loop (final-state c)))))

  (defmethod (converter <string>) ((c <collection>))
    ;; converts a collection of characters to a string
    (let ((r (make-string (size c))))
      (labels
       ((loop (s1 s2)
          (cond
           ((null s1)
        r)
           ((characterp (current-element c s1))
        ((setter current-element) r s2 (current-element c s1))
        (loop (next-state c s1) (next-state r s2)))
           (t
        (error
         (format () "list(character)->string: ~a is not a character"
             (current-element c s1))
         <Internal-Error>)))))
       (loop (initial-state c) (initial-state r)))))

  (defmethod (converter <table>) ((c <collection>))
    ;; converts any kind of collection to a table
    (let ((r (make <table>
           'comparator eq
           'hash-function generic-hash)))
      (labels
       ((loop (s)
          (if (null s)
          r
        (progn ((setter element) r (current-key c s) (current-element c s))
               (loop (next-state c s))))))
       (loop (initial-state c)))))

  (defmethod (converter <vector>) ((c <collection>))
    ;; converts any kind of collection to a vector
    (let ((r (make-vector (size c))))
      (labels
       ((loop (s1 s2)
          (if (null s1)
          r
        (progn ((setter current-element) r s2 (current-element c s1))
               (loop (next-state c s1) (next-state r s2))))))
       (loop (initial-state c) (initial-state r)))))

  ;; default methods for collections

  (defmethod key-sequence ((c <collection>))
    ;; returns a list of integers from 0 .. size of c
    (labels
     ((loop (i s)
        (if (null s)
        ()
          (cons i (loop (+ i 1) (next-state c s))))))
     (loop 0 (initial-state c))))

  (defmethod emptyp ((c <collection>)) (= 0 (size c)))

  (defmethod gf-member (v (c <collection>) f)
    ;; returns t if the application of f to v and an element of c does
    ;; see list.em for a more efficient list method
    (let/cc k
        (gf-do
         (if f
         (lambda (x) (if (f v x) (k t) ()))
           (lambda (x) (if (eql v x) (k t) ())))
         c ())))

  (defmethod gf-do (f (c <collection>) cs)
    ;; default method for iterating over several collections
    ;; simultaneously, applying the function f to the appropriate
    ;; combinations of elements and ignoring the result
    (cond
     ((null cs)
      ;; simplest case of only one iterand
      (labels
       ((loop-1 (s)
        (if (null s)
            ()
          (progn (f (current-element c s)) (loop-1 (next-state c s))))))
       (loop-1 (initial-state c))))
     ((null (cdr cs))
      ;; two iterands
      (if (or (not (sequencep c)) (not (sequencep (car cs))))
      (let ((ks (intersection (key-sequence c) (key-sequence (car cs)))))
        ;; one or more is a table therefore have to align keys
        (labels
         ((loop-2 (s c1 c2)
              (if (null s)
              ()
            (progn
              (f (element c1 (current-element ks s))
                 (element c2 (current-element ks s)))
              (loop-2 (next-state ks s) c1 c2)))))
         (loop-2 (initial-state ks) c (car cs))))
    (labels
     ;; only collections with natural order
     ((loop-2 (c1 s1 c2 s2)
          (if (or (null s1) (null s2))
              ()
            (progn
              (f (current-element c1 s1) (current-element c2 s2))
              (loop-2 c1 (next-state c1 s1) c2 (next-state c2 s2))))))
     (loop-2 c (initial-state c) (car cs) (initial-state (car cs))))))
     ((anyp (lambda (x) (not (sequencep x))) (cons c cs))
      ;; more than two iterands
      (let ((ks (apply intersection (map key-sequence (cons c cs)))))
    ;; and at least one is a table so align keys
    (labels
     ((loop-n (s cs)
          (if (null s)
              ()
            (progn
              (apply f
                 (map (lambda (c) (element c (current-element ks s))) cs))
              (loop-n (next-state ks s) cs)))))
     (loop-n (initial-state ks) (cons c cs)))))
     (t
      (labels
       ;; only natural order collections
       ((loop-n (cs ss)
        (if (anyp null ss)
            ()
          (progn
            (apply f (map (lambda (c s) (current-element c s)) cs ss))
            (loop-n cs (map (lambda (c s) (next-state c s)) cs ss))))))
       (loop-n (cons c cs) (map initial-state (cons c cs)))))))

  ;; define this here temporarily until PAB does a more efficient
  ;; version elsewhere

  (defun compose (f g) (lambda l (f (apply g l))))

  (defmethod gf-any (f (c <collection>) cs)
    ;; default method for iterating over several collections testing the
    ;; appropriate combinations of elements using f.  If this once
    ;; returns true, no further elements are processed and t is
    ;; returned.
    (let/cc k
        (apply do
           (compose (lambda (x) (if x (k t) ())) f)
           c cs)))

  (defmethod gf-map (f (c <collection>) cs)
    ;; default method for iterating over several collections
    ;; simultaneously, applying the function f to the appropriate
    ;; combinations of elements and saving the result in an object of
    ;; the same class as c, which is returned as the result.
    ;; this map method only works for sequences...see table.em for one
    ;; which works for collections without natural order and list.em for
    ;; a (slightly) more efficient list version
    (let ((r (clone c))
      (i 0))
      (apply do
         (compose (lambda (x) ((setter element) r i x) (setq i (+ i 1))) f)
         c cs)
      r))

  (defmethod accumulate (f i (c <collection>))
    ;; accumulates and returns the result of applying f to the initial
    ;; value i and the first element of c, then f to the result of that
    ;; and the second, and so on.
    (labels
     ((loop-1 (a s)
          (if (null s)
          a
        (loop-1 (f a (current-element c s)) (next-state c s)))))
     (loop-1 i (initial-state c))))

  (defmethod accumulate1 (f (c <collection>))
    ;; as accumulate except that the first value is used the initial
    ;; value and processing then begins with the second value.
    (labels
     ((loop-1 (a s)
          (if (null s)
          a
        (loop-1 (f a (current-element c s)) (next-state c s)))))
     (let ((s (initial-state c)))
       (if (null s)
       ()
     (loop-1 (current-element c s) (next-state c s))))))

  ;; fill notes
  ;; ----------
  ;; (1) replace start and end by a collection whose elements define the
  ;; keys to be updated with v.  Useful for objects with non-integer
  ;; keys, but implies need for ranges for those with integer keys.
  ;; (2) currently does nothing if start..end falls outside range defined
  ;; by 0..size.  Arguably wrong behaviour for stretchy objects (tables).
  ;; fixed by adding a method for <table> in table.em

  (defmethod fill ((mc <sequence>) v start end)
    ;; stores v in collection mc, starting at element position start and
    ;; finishing at end.
    (labels
     ((loop (i)
        (if (> i end)
        ()
          (progn ((setter element) mc i v) (loop (+ i 1))))))
     (if (and (<= 0 start) (<= start end) (< end (size mc)))
     (loop start)
       ())))

  ;; concatenate notes
  ;; -----------------
  ;; (1) uses wrong key with tables...special case for tables??
  ;; in fact, Dylan only defines this for sequence...on tables it is
  ;; more like a merge, but what to do about "collisions"?

  (defmethod gf-concatenate-as (class (c <sequence>) cs)
    ;; concatenates the elements of c and cs creating
    ;; an instance of class
    (let* ((sizes (map size (cons c cs)))
       (r (make-vector (accumulate + 0 sizes)))
       (rs (initial-state r))
       (fillptr 0))
      (do
      (lambda (c l)
        (labels
         ((loop (s)
            (if (null s)
            ()
              (progn
            ((setter current-element) r rs (current-element c s))
            (setq rs (next-state r rs))
            (loop (next-state c s))))))
         (loop (initial-state c))))
      (cons c cs)
    sizes)
      (convert r class)))

  (defmethod gf-concatenate ((c <collection>) cs)
    ;; see gf-concatenate-as
    (gf-concatenate-as (class-of c) c cs))

  (defmethod reverse ((sequence <sequence>))
    ;; returns a new sequence which has been initialized with the
    ;; elements of the argument sequence in the reverse natural order.
    ;; See also list.em for a more efficient list method.  Works for
    ;; tables but doesn't mean anything...it just makes a copy.
    (let* ((r (shallow-copy sequence))
       (rs (final-state r)))
      (do
      (lambda (x)
        ((setter current-element) r rs x)
        (setq rs (previous-state r rs)))
      sequence)
      r))

  (defun intersection (c . cs)
    ;; returns a list whose elements appear in the intersection of the
    ;; collections c and cs.  N-ary case computed by intersection of
    ;; first two, then intersection of subsequent collections with the
    ;; intersection so far.
    (cond
     ((null cs)
      c)
     ((null (cdr cs))
      (accumulate
       (lambda (a x) (if (member x c) (cons x a) a))
       ()
       (car cs)))
     (t
      (accumulate
       (lambda (r ci)
     (accumulate
      (lambda (a x) (if (member x r) (cons x a) a))
      ()
      ci))
       (accumulate
    (lambda (a x) (if (member x c) (cons x a) a))
    ()
    (car cs))
       (cdr cs)))))

  ;; Copying protocol
  (defmethod clone ((x <collection>))
    (nyi "Subclass must implement clone"))

  (defmethod shallow-copy ((collect <collection>))
    (let ((new (clone collect))
      (state (initial-state collect)))
      (do (lambda (value)
        ((setter current-element) collect state value)
        (setq state (next-state collect state)))
      collect)
      new))

  (defmethod deep-copy ((collect <collection>))
    (let ((new (clone collect))
      (state (initial-state collect)))
      (do (lambda (value)
        ((setter current-element) collect state (deep-copy value))
        (setq state (next-state collect state)))
      collect)
      new))

  )

(setq a '(0 1 2 3 4))
(setq b '#(0 1 2 3))
(setq c "012")
(setq d (make <table> 'comparator = 'hash-function generic-hash))
((setter element) d 0 'zero)
((setter element) d 1 'one)

(do print a)
(do print b)
(do print c)
(do print d)
(do (lambda (a b) (print (list a b))) a b)
(do (lambda (a b) (print (list a b))) c a)
(do (lambda (a b) (print (list a b))) a d)
(do (lambda (a b) (print (list a b))) d a)
(do (lambda (a b c) (print (list a b c))) a b c)
(do (lambda (a b c d) (print (list a b c d))) a b c d)

(defmethod select (f (c <collection>))
  (labels
    ((loop-1 (s)
       (if (null s)
       ()
     (progn
       (f (current-key c s) (current-element c s))
       (loop-1 (next-state c s))))))
    (loop-1 (initial-state c))))

(defgeneric accumulate-with-key (f i c))

(defmethod accumulate-with-key (f i (c <collection>))
  ;; accumulates and returns the result of applying f to the initial
  ;; value i and the first element of c, then f to the result of that
  ;; and the second, and so on.
  (labels
   ((loop-1 (a s)
      (if (null s)
      a
    (loop-1 (f a (current-key c s) (current-element c s))
        (next-state c s)))))
   (loop-1 i (initial-state c))))

(defgeneric copy-sequence (s i j))
(export copy-sequence)

(defmethod copy-sequence ((s <sequence>) start end)
  (let/cc k
    (accumulate-with-key
     (lambda (a key value)
       (format t "a, key, value = ~a, ~a, ~a~%" a key value)
       (cond
    ((< key start) a)
    ((<= key end) (cons value a))
    (t (k (reverse a)))))
     ()
     s)))

(defmethod fill ((s <sequence>) v start end)
  (let/cc k
    (accumulate-with-key
     (lambda (a key value)
       (format t "a, key, value = ~a, ~a, ~a~%" a key value)
       (cond
    ((< key start) ())
    ((<= key end) ((setter element) s key v))
    (t (k ()))))
     ()
     s)))