git.fiddlerwoaroof.com
derived/ix-enum.scm
4e987026
 ;;; ----------------------------------------------------------------
 ;;;  Ix
 ;;; ----------------------------------------------------------------
 
 (define (ix-fns algdata)
   (if (algdata-enum? algdata)
       (ix-fns/enum algdata)
       (ix-fns/tuple algdata)))
 
 (define (ix-fns/enum algdata)
  (list 
    (**define '|range| '((tuple |l| |u|))
      (**let
       (list
        (**define '|cl| '() (**con-number (**var '|l|) algdata))
        (**define '|cu| '() (**con-number (**var '|u|) algdata)))
       (**if (**< (**var '|cu|) (**var '|cl|))
 	    (**null)
 	    (**take (**+ (**- (**var '|cu|) (**var '|cl|)) (**int 1))
 		    (**drop (**var '|cl|)
 		      (**list/l
 		       (map (function **con/def)
 			    (algdata-constrs algdata))))))))
    (**define '|index| '((tuple |l| |u|) |x|)
       (**- (**con-number (**var '|x|) algdata)
 	   (**con-number (**var '|l|) algdata)))
    (**define '|inRange| '((tuple |l| |u|) |x|)
       (**and (**<= (**con-number (**var '|l|) algdata)
 		   (**con-number (**var '|x|) algdata))
 	     (**<= (**con-number (**var '|x|) algdata)
 		   (**con-number (**var '|u|) algdata))))))
 
 (define (ix-fns/tuple algdata)
   (let* ((con (tuple-con algdata))
 	 (arity (con-arity con))
 	 (llist (temp-vars "l" arity))
 	 (ulist (temp-vars "u" arity))
 	 (ilist (temp-vars "i" arity)))
    (list
     (**define '|range| `((tuple (,con ,@llist) (,con ,@ulist)))
       (**listcomp (**app/l (**con/def con) (map (function **var) ilist))
 		  (map (lambda (iv lv uv)
 			  (**gen iv
 			       (**app (**var '|range|)
 				      (**tuple2 (**var lv)
 						(**var uv)))))
 			ilist llist ulist)))
     (**define '|index| `((tuple (,con ,@llist) (,con ,@ulist))
 			 (,con ,@ilist))
 	  (index-body (reverse ilist) (reverse llist) (reverse ulist)))
     (**define '|inRange| `((tuple (,con ,@llist) (,con ,@ulist))
 			   (,con ,@ilist))
 		(inrange-body ilist llist ulist)))))
 
 (define (index-body is ls us)
   (let ((i1 (**app (**var '|index|)
 		   (**tuple2 (**var (car ls)) (**var (car us)))
 		   (**var (car is)))))
     (if (null? (cdr is))
 	i1
 	(**app (**var '|+|)
 	       i1 (**app (**var '|*|)
 			 (**1+ (**app (**var '|index|)
 				      (**tuple2 (**var (car ls))
 						(**var (car us)))
 				      (**var (car us))))
 			 (index-body (cdr is) (cdr ls) (cdr us)))))))
 
 (define (inrange-body is ls us)
   (let ((i1 (**app (**var '|inRange|)
 		   (**tuple2 (**var (car ls)) (**var (car us)))
 		   (**var (car is)))))
     (if (null? (cdr is))
 	i1
 	(**app (**var/def (core-symbol "&&"))
 	       i1
 	       (inrange-body (cdr is) (cdr ls) (cdr us))))))
 
 ;;; ----------------------------------------------------------------
 ;;;  Enum
 ;;; ----------------------------------------------------------------
 
 ; Enum uses the Int methods since Enums are represented as Ints.
 
 (define (enum-fns algdata)
   (list
    (**define '|enumFrom| '(|x|)
        (**let
 	 (list
 	  (**define '|from'| '(|x'|)
 	      (**if (**> (**var '|x'|)
 			 (**con-number (**con/def (last-con algdata)) algdata))
 		    (**null)
 		    (**cons (**var '|x'|)
 			    (**app (**var '|from'|) (**1+ (**var '|x'|)))))))
 	 (**cast (**app (**var '|from'|)
 			(**con-number (**var '|x|) algdata)))))
    (**define '|enumFromThen| '(|x| |y|)
      (**let
       (list
        (**define '|step| '()
 	 (**- (**con-number (**var '|y|) algdata)
 	      (**con-number (**var '|x|) algdata)))
        (**define '|from'| '(|x'|)
 	(**if (**or (**> (**var '|x'|)
 			 (**con-number (**con/def (last-con algdata)) algdata))
 		    (**< (**var '|x'|) (**int 0)))
 	      (**null)
 	      (**cons (**var '|x'|)
 		      (**app (**var '|from'|)
 			     (**+ (**var '|x'|) (**var '|step|)))))))
       (**cast (**app (**var '|from'|) (**con-number (**var '|x|) algdata)))))))
 
 (define (last-con algdata)
   (car (reverse (algdata-constrs algdata))))