Language/OS - Multiplatform Resource Library/LANGUAGE OS.iso/scheme/schmlbrr/schem_lb.lha/unsupported/CScheme/array.scm

Text File | 1991-08-05 | 8.2 KB | 270 lines

;;;-*- Base: 10; Mode: Scheme; Syntax: MIT Scheme; Package: USER -*-
;;
;; ARRAY.SCM
;;
;; July 1, 1991
;; Minghsun Liu
;;
;; This file contains procedures written in MIT Scheme that implement
;; a data type that is anologous to the arrays found in CommonLisp.
;; The main idea is to use vectors whose elements are also vectors to
;; implement the multi-dimensionality of arrays.
;;
;; July 19, 1991
;; Major Overhawl: All the codes are re-written using message passing
;; style of programming.
;;
;; July 26, 1991
;; Yet Another Major Overhawl: the requirement of :displaced-to suggests
;; that a flattened internal representation of the array is the ideal
;; implementation.
;;
;; July 30, 1991
;; Elimination of support for :displaced-to keyword.  The original
;; implementation with support for :displaced-to can be found in
;; array-displaced.scm
;;
;;
;; The following(s) are(is) defined:
;;
;; :INITIAL-CONTENTS
;; :INITIAL-ELEMENT
;; (MAKE-ARRAY DIMENSIONS . OPTIONS)
;; (AREF ARRAY . SUBSCRIPTS)
;; (ARRAY-RANK ARRAY)
;; (ARRAY-DIMENSIONS)
;; (ARRAY-DIMENSION ARRAY AXIS-NUMBER)
;; (ARRAY? ARRAY)
;; (ARRAY-SET! ARRAY OBJ . SUBSCRIPTS)
;; (JUST-THE-ARRAY-MAAM ARRAY)
;; (CHANGE-MYSELF ARRAY NEW-DATA)
;;
(declare (usual-integrations))

;;
;; :INITIAL-CONTENTS
;; :INITIAL-ELEMENT
;;
;; are constants whose values should not be changed.
;;
(define :initial-contents (cons ':initial-contents 'keyword-constant))
(define :initial-element (cons ':initial-element 'keyword-constant))

;;
;; (MAKE-ARRAY DIMENSIONS #!REST OPTIONS)
;;
;; creates a array with its dimensions specified by DIMENSIONS which
;; should be a list of non-negative integers with the length of the
;; list being the rank of the array.
;;
(define (make-array dimensions #!rest options)
  (let ((initialize-array? #f)
    (initial-element? #t)
    (cur-array '())
    (initial-object '()))
    (define (flatten a-list)  ;; ahhh....a-list been run over by a truck
      (cond ((null? a-list)
         '())
        ((pair? (car a-list))
         (append (flatten (car a-list))
             (flatten (cdr a-list))))
        (else
         (cons (car a-list)
           (flatten (cdr a-list))))))
    (define (list->array dims flat-list)
      (if (and (= (length flat-list) dims)
           (not (list-transform-positive flat-list pair?)))
      (list->vector flat-list)
      (error "MAKE-ARRAY: displaced -> something is WRONG!!" flat-list dims)))
    (define (check-options options-left)
      (cond ((null? options-left)
         'done)
        ((equal? (car options-left) :initial-contents)
         (set! initial-element? #f)
         (set! initialize-array? #t)
         (set! initial-object (cadr options-left))
         (check-options (cddr options-left)))
        ((equal? (car options-left) :initial-element)
             (set! initialize-array? #t)
         (set! initial-object (cadr options-left))
         (check-options (cddr options-left)))
        (else (error "MAKE-ARRAY: unknown keyword" options-left))))
    (define (translate subscripts)  ;; collapse the world down to 1D
      (define (trans-aux subs dims)
    (if (null? (cddr subs))
        (+ (* (cadr subs) (car dims)) (car subs))
        (trans-aux (cons (+ (* (cadr subs) (car dims)) (car subs))
                 (cddr subs))
               (cons (* (car dims) (cadr dims)) (cddr dims)))))
      (let ((trans-index
         (if (= (length subscripts) (length dimensions))
         (if (= (length subscripts) 1)
             (car subscripts)
             (trans-aux (reverse subscripts) (reverse dimensions)))
         (error "ARRAY: invalid index" subscripts dimensions))))
    (if (>= trans-index (vector-length cur-array))
        (error "TRANSLATE-ARRAY: bad index" subscripts trans-index)
        trans-index)))
    (define (m-array-ref subscripts)
      (cond ((and (null? subscripts) (not (vector? cur-array)) (null? dimensions))
         cur-array)
        ((list? subscripts)
         (vector-ref cur-array (translate subscripts)))
        (else
         (error "AREF: array corrupt or bad index" cur-array subscripts dimensions))))
    (define (m-array-rank)
      (length dimensions))
    (define (m-array-dimension axis-number)
      (list-ref axis-number dimensions))
    (define (m-array-dimensions)
      (if (null? dimensions)
      '()
      dimensions))
    (define (m-array-set! arguements)
      (let ((obj (car arguements))
        (ind (if (null? (cdr arguements))
             '()
             (translate (cdr arguements)))))
    (define (array-set-aux!)
      (vector-set! cur-array ind obj)
      obj)
    (define (array-set-aux-2!)
      (set! cur-array obj)
      obj)
    (if (and (null? ind) (null? dimensions))
        (array-set-aux-2!)
        (if (and (not (null? ind)) (not (null? dimensions)))
        (array-set-aux!)
        (error "ARRAY-SET: bad index" arguements)))))
    (define (array-type msg #!rest args)
      (case msg
    ((array-ref) (m-array-ref args))
    ((array-rank) (m-array-rank))
    ((array-dimension) (m-array-dimension (car args)))
    ((array?) #t)
    ((array-dimensions) (m-array-dimensions))
    ((array-set!) (m-array-set! args))
    ((just-the-array-maam) cur-array)
    ((change-myself) (set! cur-array (car args)))  ;; change yourself, i.e. destructive.
    (else (error "ARRAY: not a valid method" msg))))
    (check-options options)
    (set! cur-array
      (if (or (number? dimensions) (= 1 (length dimensions)) (null? dimensions))
          (if (number? dimensions)
          (if initialize-array?
              (if initial-element?
              (make-vector dimensions initial-object)
              (if (= (length initial-object) dimensions)
                  (list->vector initial-object)
                  (error "MAKE-ARRAY: array is not of correct size"
                     dimensions initial-object)))
              (make-vector dimensions))
          (if (null? dimensions)
              (if initialize-array?
              initial-object
              0)
              (if initialize-array?
              (if initial-element?
                  (make-vector (car dimensions) initial-object)
                  (if (= (length initial-object) (car dimensions))
                  (list->vector initial-object)
                  (error "MAKE-ARRAY: array is not of correct size"
                     (car dimensions) initial-object)))
              (make-vector (car dimensions)))))
          (if (and initialize-array? (not initial-element?))
          (list->array (apply * dimensions) (flatten initial-object))
          (if initial-element?
              (make-vector (apply * dimensions) initial-object)
              (make-vector (apply * dimensions))))))
    array-type))


;;
;; (AREF ARRAY . SUBSCRIPTS)
;;
;; access and returns the element of array specified by the SUBSCRIPTS
;; whose number must equal the rank of the array.
;;
(define (aref array #!rest subscripts)
  (apply array 'array-ref subscripts))


;;
;; (ARRAY-RANK ARRAY)
;;
;; returns the number of dimensions of ARRAY.  One limitation of
;; current implementation is that the elements in the array can't
;; be vectors.
;;
(define (array-rank array)
  (array 'array-rank))


;;
;; (ARRAY-DIMENSION ARRAY AXIS-NUMBER)
;;
;; returns the length of dimension number AXIS-NUMBER of ARRAY.
;;
(define (array-dimensions array axis-number)
  (array 'array-dimensions axis-number))


;;
;; (ARRAY-DIMENSIONS ARRAY)
;;
;; get the dimensions of ARRAY.
;;
(define (array-dimensions array)
  (array 'array-dimensions))


;;
;; (ARRAY? OBJECT)
;;
;; tests if object is an array.
;;
(define (array? object)
  (if (procedure? object)
      (object 'array?)
      #f))


;;
;; (ARRAY-SET! ARRAY OBJ . SUBSCRIPTS)
;;
;; destructively replace an array element of index SUBSCRIPTS with the
;; value OBJ.  (Note: the ordering of arguements is a little different
;; from that in CL: (setf (aref an-array ind) obj).)
;;
(define (array-set! array obj #!rest subscripts)
  (apply array 'array-set! obj subscripts))


;;
;; (JUST-THE-ARRAY-MAAM ARRAY)
;;
;; like the name says: a wicked way to get the vector that stores
;; the data in the array only, instead of the whole procedural object.
;; This is one way to implement operations on the array without adding
;; methods to the object.
;;
(define (just-the-array-maam array)
  (array 'just-the-array-maam))


;;
;; (CHANGE-MYSELF ARRAY NEW-DATA)
;;
;; coupled with the above procedure, JUST-THE-ARRAY-MAAM, provide the
;; facilities to write operations on arrays as independent procedures,
;; instead of a new method in the ARRAY object.  This method, however,
;; does not check the consistency of NEW-DATA with the characteristics
;; of the array.  (e.g. If the array is a 2 by 2 array, it is assumed
;; that NEW-DATA is a vector that contains at least 4 elements.)
;;
(define (change-myself array new-data)
  (array 'change-myself new-data))