home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / schmlbrr / schem_lb.lha / unsupported / CScheme / array-displaced.scm next >
Encoding:
Text File  |  1991-08-05  |  9.9 KB  |  330 lines
  1. ;;;-*- Base: 10; Mode: Scheme; Syntax: MIT Scheme; Package: USER -*-
  2. ;;
  3. ;; ARRAY-DISPLACED.SCM
  4. ;;
  5. ;; July 1, 1991
  6. ;; Minghsun Liu
  7. ;;
  8. ;; This file contains procedures written in MIT Scheme that implement
  9. ;; a data type that is anologous to the arrays found in CommonLisp.
  10. ;; The main idea is to use vectors whose elements are also vectors to
  11. ;; implement the multi-dimensionality of arrays.
  12. ;;
  13. ;; July 19, 1991
  14. ;; Major Overhawl: All the codes are re-written using message passing.
  15. ;;
  16. ;; July 26, 1991
  17. ;; Yet Another Major Overhawl: the requirement of :displaced-to suggests
  18. ;; that a flattened internal representation of the array is the ideal
  19. ;; implementation.
  20. ;;
  21. ;;
  22. ;; August 5, 1991
  23. ;; This file contains the original implementation of the array data
  24. ;; type with supports for :displaced-to keyword.  The implementation
  25. ;; is still buggy for it has not undergone any extensive tests.  USE
  26. ;; WITH CAUTION! 
  27. ;
  28. ;; The following(s) are(is) defined:
  29. ;;
  30. ;; :INITIAL-CONTENTS
  31. ;; :INITIAL-ELEMENT
  32. ;; (MAKE-ARRAY DIMENSIONS . OPTIONS)
  33. ;; (ARRAY-REF ARRAY . SUBSCRIPTS)
  34. ;; (ARRAY-RANK ARRAY)
  35. ;; (ARRAY-DIMENSION ARRAY AXIS-NUMBER)
  36. ;; (ARRAY? ARRAY)
  37. ;; (ARRAY-SET! ARRAY OBJ . SUBSCRIPTS)
  38. ;; (JUST-THE-ARRAY-MAAM ARRAY)
  39. ;; (CHANGE-MYSELF ARRAY NEW-DATA)
  40. ;;
  41. (declare (usual-integrations))
  42.  
  43.  
  44. ;;
  45. ;; :INITIAL-CONTENTS
  46. ;; :INITIAL-ELEMENT
  47. ;;
  48. ;; are constants whose values should not be changed.
  49. ;;
  50. (define :initial-contents (cons ':initial-contents 'keyword-constant))
  51. (define :initial-element (cons ':initial-element 'keyword-constant))
  52. (define :displaced-to (cons ':displaced-to 'keyword-constant))
  53.  
  54.  
  55. ;;
  56. ;; (MAKE-ARRAY DIMENSIONS #!REST OPTIONS)
  57. ;;
  58. ;; creates a array with its dimensions specified by DIMENSIONS which
  59. ;; should be a list of non-negative integers with the length of the
  60. ;; list being the rank of the array.
  61. ;;
  62. (define (make-array dimensions #!rest options)
  63.   (let ((initialize-array? #f)
  64.     (initial-element? #t)
  65.     (cur-array '())
  66.     (initial-object '()))
  67.     (define (flatten a-list)  ;; ahhh....a-list been run over by a truck
  68.       (cond ((null? a-list)
  69.          '())
  70.         ((pair? (car a-list))
  71.          (append (flatten (car a-list))
  72.              (flatten (cdr a-list))))
  73.         (else
  74.          (cons (car a-list)
  75.            (flatten (cdr a-list))))))
  76.     (define (list->array dims flat-list)
  77.       (if (and (= (length flat-list) dims)
  78.            (not (list-transform-positive flat-list pair?)))
  79.       (list->vector flat-list)
  80.       (error "MAKE-ARRAY: displaced -> something is WRONG!!" flat-list dims)))
  81.     (define (check-options options-left)
  82.       (cond ((null? options-left)
  83.          'done)
  84.         ((equal? (car options-left) :initial-contents)
  85.          (set! initial-element? #f)
  86.          (set! initialize-array? #t)
  87.          (set! initial-object (cadr options-left))
  88.          (check-options (cddr options-left)))
  89.         ((equal? (car options-left) :initial-element)
  90.              (set! initialize-array? #t)
  91.          (set! initial-object (cadr options-left))
  92.          (check-options (cddr options-left)))
  93.         ((equal? (car options-left) :displaced-to)
  94.          (set! displaced-to? #t)
  95.          (set! destin-array (cadr options-left))
  96.          (check-options (cddr options-left)))
  97.         (else (error "MAKE-ARRAY: unknown keyword" options-left))))
  98.     (define (translate subscripts)  ;; collapse the world down to 1D
  99.       (define (trans-aux subs dims)
  100.     (if (null? (cddr subs)) 
  101.         (+ (* (cadr subs) (car dims)) (car subs))
  102.         (trans-aux (cons (+ (* (cadr subs) (car dims)) (car subs))
  103.                  (cddr subs))
  104.                (cons (* (car dims) (cadr dims)) (cddr dims)))))
  105.       (let ((trans-index
  106.          (if (= (length subscripts) (length dimensions))
  107.          (if (= (length subscripts) 1)
  108.              (car subscripts)
  109.              (trans-aux (reverse subscripts) (reverse dimensions)))
  110.          (error "ARRAY: invalid index" subscripts dimeensions))))
  111.     (if (>= trans-index (vector-length cur-array))
  112.         (error "TRANSLATE-ARRAY: bad index" subscripts trans-index)
  113.         trans-index)))
  114.     (define (m-array-ref subscripts)
  115.       (cond ((and (null? subscripts) (null? dimensions))
  116.          cur-array)
  117.         ((list? subscripts)
  118.          (vector-ref cur-array (translate subscripts)))
  119.         (else
  120.          (error "AREF: array corrupt or bad index" cur-array subscripts dimensions))))
  121.     (define (m-array-rank)
  122.       (length dimensions))
  123.     (define (m-array-dimension axis-number)
  124.       (list-ref axis-number dimensions))
  125.     (define (m-array-dimensions)
  126.       (if (null? dimensions)
  127.       '()
  128.       dimensions))
  129.     (define (m-array-set! arguements)
  130.       (let ((obj (car arguements))
  131.         (ind (if (null? (cdr arguements))
  132.              '()
  133.              (translate (cdr arguements)))))
  134.     (define (array-set-aux!)
  135.       (vector-set! cur-array ind obj)
  136.       obj)
  137.     (define (array-set-aux-2!)
  138.       (set! cur-array obj)
  139.       obj)
  140.     (define (propagate-obj)
  141.       (desin-array 'fast-array-set! obj ind)) 
  142.     (if (and (null? ind) (null? dimensions))
  143.         (if displaced-to?
  144.         (begin
  145.           (array-set-aux-2!)
  146.           (propagate-obj))
  147.         (array-set-aux-2!))
  148.         (if (and (not (null? ind)) (not (null? dimensions)))
  149.         (if displaced-to?
  150.             (begin
  151.               (array-set-aux!)
  152.               (propagate-obj))
  153.             (array-set-aux!))
  154.         (error "ARRAY-SET: bad index" arguements)))))
  155.     (define (copy-array)
  156.       (let ((to-be-copied (destin-array 'just-the-array-maam))
  157.         (destin-dim (destin-array 'array-dimensions)))
  158.     (cond ((and (null? dimensions) (null? destin-dim))
  159.            to-be-copied)
  160.           ((and (not (null? dimensions)) (null? destin-dim))
  161.            (subvector (vector to-be-copied) 0 (max 1 (if (number? dimensions)
  162.                                  dimensions
  163.                                  (apply * dimensions)))))
  164.           ((and (null? dimensions) (not (null? destin-dim)))
  165.            (vector-ref to-be-copied 0))
  166.           (else
  167.            (if (number? dimensions)
  168.            (subvector to-be-copied 0 (min dimensions
  169.                           (if (number? destin-dim)
  170.                               destin-dim
  171.                               (apply * destin-dim))))
  172.            (subvector to-be-copied 0 (min (if (number? destin-dim)
  173.                               destin-dim
  174.                               (apply * destin-dim))
  175.                           (apply * dimensions))))))))
  176.     (define (array-type msg #!rest args)
  177.       (case msg
  178.     ((dispaced)
  179.      (set! displaced-to? #t)
  180.      (set! destin-array (car args))
  181.      (car args))
  182.     ((fast-array-set!)
  183.      (if (and (null? dimensions)
  184.           (or (null? (cdr args))
  185.               (> 1 (cadr args))))
  186.          (set! cur-array (car args))
  187.          (if (null? (cdr args))
  188.          (vector-set! cur-array 0 (car args))
  189.          (vector-set! cur-array (cadr args) (car args)))))
  190.     ((array-ref) 
  191.      (if displaced-to?
  192.          (set! cur-array (copy-array)))
  193.      (m-array-ref args))
  194.     ((array-rank) (m-array-rank))
  195.     ((array-dimension) (m-array-dimension (car args)))
  196.     ((array?) #t)
  197.     ((array-dimensions) (m-array-dimensions))
  198.     ((array-set!) (m-array-set! args))
  199.     ((just-the-array-maam) 
  200.      (if displaced-to?
  201.          (set! cur-array (copy-array)))
  202.      cur-array)
  203.     ((change-myself) 
  204.      (set! cur-array (car args))  ;; change yourself, i.e.
  205.                       ;; destructive.
  206.      (destin-array 'change-my-self (car args)))
  207.     (else (error "ARRAY: not a valid method" msg))))
  208.     (check-options options)
  209.     (set! cur-array
  210.       (if displaced-to?
  211.           (copy-array)
  212.           (if (or (number? dimensions) (= 1 (length dimensions)) (null? dimensions))
  213.           (if (number? dimensions)
  214.               (if initialize-array? 
  215.               (if initial-element?
  216.                   (make-vector dimensions initial-object)
  217.                   (if (= (length initial-object) dimensions)
  218.                   (list->vector initial-object)
  219.                   (error "MAKE-ARRAY: array is not of correct size"
  220.                      dimensions initial-object)))
  221.               (make-vector dimensions))
  222.               (if (null? dimensions)
  223.               (if initialize-array?
  224.                   initial-object
  225.                   0)
  226.               (if initialize-array?
  227.                   (if initial-element?
  228.                   (make-vector (car dimensions) initial-object)
  229.                   (if (= (length initial-object) (car dimensions))
  230.                       (list->vector initial-object)
  231.                       (error "MAKE-ARRAY: array is not of correct size"
  232.                          (car dimensions) initial-object)))
  233.                   (make-vector (car dimensions)))))
  234.           (if (and initialize-array? (not initial-element?))
  235.               (list->array (apply * dimensions) (flatten initial-object))
  236.               (if initial-element?
  237.               (make-vector (apply * dimensions) initial-object)
  238.               (make-vector (apply * dimensions)))))))
  239.     (if displaced-to?
  240.     (destin-array 'displaced array-type)
  241.     array-type)))
  242.  
  243.  
  244. ;;
  245. ;; (AREF ARRAY . SUBSCRIPTS)
  246. ;;
  247. ;; access and returns the element of array specified by the SUBSCRIPTS
  248. ;; whose number must equal the rank of the array.
  249. ;;
  250. (define (aref array #!rest subscripts)
  251.   (apply array 'array-ref subscripts))
  252.  
  253.  
  254. ;;
  255. ;; (ARRAY-RANK ARRAY)
  256. ;;
  257. ;; returns the number of dimensions of ARRAY.  One limitation of
  258. ;; current implementation is that the elements in the array can't
  259. ;; be vectors.
  260. ;;
  261. (define (array-rank array)
  262.   (array 'array-rank))
  263.  
  264.  
  265. ;;
  266. ;; (ARRAY-DIMENSION ARRAY AXIS-NUMBER)
  267. ;;
  268. ;; returns the length of dimension number AXIS-NUMBER of ARRAY.
  269. ;;
  270. (define (array-dimensions array axis-number)
  271.   (array 'array-dimensions axis-number))
  272.  
  273.  
  274. ;;
  275. ;; (ARRAY-DIMENSIONS ARRAY)
  276. ;;
  277. ;; get the dimensions of ARRAY.
  278. ;;
  279. (define (array-dimensions array)
  280.   (array 'array-dimensions))
  281.  
  282.  
  283. ;;
  284. ;; (ARRAY? OBJECT)
  285. ;;
  286. ;; tests if object is an array.
  287. ;;
  288. (define (array? object)
  289.   (if (procedure? object)
  290.       (object 'array?)
  291.       #f))
  292.  
  293.  
  294. ;;
  295. ;; (ARRAY-SET! ARRAY OBJ . SUBSCRIPTS)
  296. ;;
  297. ;; destructively replace an array element of index SUBSCRIPTS with the
  298. ;; value OBJ. 
  299. ;;
  300. (define (array-set! array obj #!rest subscripts)
  301.   (apply array 'array-set! obj subscripts))
  302.  
  303.  
  304. ;;
  305. ;; (JUST-THE-ARRAY-MAAM ARRAY)
  306. ;;
  307. ;; like the name says: a wicked way to get the multidimensional array
  308. ;; only, instead of the whole procedural object.
  309. ;;
  310. (define (just-the-array-maam array)
  311.   (array 'just-the-array-maam))
  312.  
  313.  
  314. ;;
  315. ;; (CHANGE-MYSELF ARRAY NEW-DATA)
  316. ;;
  317. ;; coupled with the above procedure, JUST-THE-ARRAY-MAAM, provide the
  318. ;; facilities to write operations on arrays as independent procedures,
  319. ;; instead of a new method in the ARRAY object.  This method, however,
  320. ;; does not check the consistency of NEW-DATA with the characteristics
  321. ;; of the array.  (e.g. If the array is a 2 by 2 array, it is assumed
  322. ;; that NEW-DATA is a vector that contains at least 4 elements.)
  323. ;;
  324. (define (change-myself array new-data)
  325.   (array 'change-myself new-data))
  326.  
  327.  
  328.  
  329.  
  330.