home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / MacHaskell 2.2 / derived / ix-enum.scm < prev    next >
Encoding:
Text File  |  1994-09-27  |  4.0 KB  |  128 lines  |  [TEXT/CCL2]
  1. ;;; ----------------------------------------------------------------
  2. ;;;  Ix
  3. ;;; ----------------------------------------------------------------
  4.  
  5. (define (ix-fns algdata)
  6.   (if (algdata-enum? algdata)
  7.       (ix-fns/enum algdata)
  8.       (ix-fns/tuple algdata)))
  9.  
  10. (define (ix-fns/enum algdata)
  11.  (list 
  12.    (**define '|range| '((tuple |l| |u|))
  13.      (**let
  14.       (list
  15.        (**define '|cl| '() (**con-number (**var '|l|) algdata))
  16.        (**define '|cu| '() (**con-number (**var '|u|) algdata)))
  17.       (**if (**< (**var '|cu|) (**var '|cl|))
  18.         (**null)
  19.         (**take (**+ (**- (**var '|cu|) (**var '|cl|)) (**int 1))
  20.             (**drop (**var '|cl|)
  21.              (if (algdata-implemented-by-lisp? algdata)
  22.               (**list/l
  23.                (map (function **con/def)
  24.                 (algdata-constrs algdata)))
  25.               (**cast
  26.                (make sequence-to
  27.                 (from (**int 0))
  28.                 (to (**int (1- (algdata-n-constr algdata))))))))))))
  29.    (**define '|index| '((tuple |l| |u|) |x|)
  30.      (**if (**app (**var '|inRange|)
  31.           (**tuple2 (**var '|l|) (**var '|u|))
  32.           (**var '|x|))
  33.        (**- (**con-number (**var '|x|) algdata)
  34.         (**con-number (**var '|l|) algdata))
  35.        (**app (**var/def (core-symbol "indexError"))
  36.           (**var '|x|)
  37.           (**var '|l|)
  38.           (**var '|u|))))
  39.    (**define '|inRange| '((tuple |l| |u|) |x|)
  40.       (**and (**<= (**con-number (**var '|l|) algdata)
  41.            (**con-number (**var '|x|) algdata))
  42.          (**<= (**con-number (**var '|x|) algdata)
  43.            (**con-number (**var '|u|) algdata))))))
  44.  
  45. (define (ix-fns/tuple algdata)
  46.   (let* ((con (tuple-con algdata))
  47.      (arity (con-arity con))
  48.      (llist (temp-vars "l" arity))
  49.      (ulist (temp-vars "u" arity))
  50.      (ilist (temp-vars "i" arity)))
  51.    (list
  52.     (**define '|range| `((tuple (,con ,@llist) (,con ,@ulist)))
  53.       (**listcomp (**app/l (**con/def con) (map (function **var) ilist))
  54.           (map (lambda (iv lv uv)
  55.               (**gen iv
  56.                    (**app (**var '|range|)
  57.                       (**tuple2 (**var lv)
  58.                         (**var uv)))))
  59.             ilist llist ulist)))
  60.     (**define '|index| `((tuple (,con ,@llist) (,con ,@ulist))
  61.              (,con ,@ilist))
  62.       (index-body (reverse ilist) (reverse llist) (reverse ulist)))
  63.     (**define '|inRange| `((tuple (,con ,@llist) (,con ,@ulist))
  64.                (,con ,@ilist))
  65.         (inrange-body ilist llist ulist)))))
  66.  
  67. (define (index-body is ls us)
  68.   (let ((i1 (**app (**var '|index|)
  69.            (**tuple2 (**var (car ls)) (**var (car us)))
  70.            (**var (car is)))))
  71.     (if (null? (cdr is))
  72.     i1
  73.     (**app (**var '|+|)
  74.            i1 (**app (**var '|*|)
  75.              (**1+ (**app (**var '|index|)
  76.                       (**tuple2 (**var (car ls))
  77.                         (**var (car us)))
  78.                       (**var (car us))))
  79.              (index-body (cdr is) (cdr ls) (cdr us)))))))
  80.  
  81. (define (inrange-body is ls us)
  82.   (let ((i1 (**app (**var '|inRange|)
  83.            (**tuple2 (**var (car ls)) (**var (car us)))
  84.            (**var (car is)))))
  85.     (if (null? (cdr is))
  86.     i1
  87.     (**app (**var/def (core-symbol "&&"))
  88.            i1
  89.            (inrange-body (cdr is) (cdr ls) (cdr us))))))
  90.  
  91. ;;; ----------------------------------------------------------------
  92. ;;;  Enum
  93. ;;; ----------------------------------------------------------------
  94.  
  95. ; Enum uses the Int methods since Enums are represented as Ints.
  96.  
  97. (define (enum-fns algdata)
  98.   (list
  99.    (**define '|enumFrom| '(|x|)
  100.        (**let
  101.      (list
  102.       (**define '|from'| '(|x'|)
  103.           (**if (**> (**var '|x'|)
  104.              (**con-number (**con/def (last-con algdata)) algdata))
  105.             (**null)
  106.             (**cons (**var '|x'|)
  107.                 (**app (**var '|from'|) (**1+ (**var '|x'|)))))))
  108.      (**cast (**app (**var '|from'|)
  109.             (**con-number (**var '|x|) algdata)))))
  110.    (**define '|enumFromThen| '(|x| |y|)
  111.      (**let
  112.       (list
  113.        (**define '|step| '()
  114.      (**- (**con-number (**var '|y|) algdata)
  115.           (**con-number (**var '|x|) algdata)))
  116.        (**define '|from'| '(|x'|)
  117.     (**if (**or (**> (**var '|x'|)
  118.              (**con-number (**con/def (last-con algdata)) algdata))
  119.             (**< (**var '|x'|) (**int 0)))
  120.           (**null)
  121.           (**cons (**var '|x'|)
  122.               (**app (**var '|from'|)
  123.                  (**+ (**var '|x'|) (**var '|step|)))))))
  124.       (**cast (**app (**var '|from'|) (**con-number (**var '|x|) algdata)))))))
  125.  
  126. (define (last-con algdata)
  127.   (car (reverse (algdata-constrs algdata))))
  128.