build-cxrs.shen

\* Build Lisp CxRS *\ 
\* CC Part *\ 

(defcc <expr> X <expr> := [X | <expr>]; <e> := [];)
(defcc <a-d-to-head-tail>
 "a" <a-d-to-head-tail> := [head <a-d-to-head-tail>];
 "d" <a-d-to-head-tail> := [tail <a-d-to-head-tail>];
 "r" <expr> := <expr>;)
(defcc <cxr?>
 "c" "a" <a-d-to-head-tail> := [head <a-d-to-head-tail>];
 "c" "d" <a-d-to-head-tail> := [tail <a-d-to-head-tail>];)
(define cxr?
 Sym Expr <- (compile (function <cxr?>) (append (explode (str Sym))
[Expr]))
 _ _ -> (fail))

\* global solution:
(defmacro mymacro
 [X Y] <- (cxr? X Y))
*\ 

\* Prolog Part *\ 

(defprolog delete
  X [X|Tail] Tail <--;
  X [H|Tail] [H|NT] <-- (delete X Tail NT);)

(defprolog variations
  0 _ [] <--;
  N L [H | Var] <-- (when (> N 0)) (is N1 (- N 1)) (delete H L _) (variations N1 L Var);)

(define cxr-variations
  N -> (prolog? (findall X [variations N [d a] X] Y)
		  (return Y)))

\* Functional Part *\ 

(define foldl
  {(A --> B --> A) --> A --> (list B) --> A}
  Fn A [B] -> (Fn A B)
  Fn A [B|BS] -> (foldl Fn (Fn A B) BS))

(define separate-aux
  {(A --> boolean) --> (list A) --> (list A) --> (list A)
    --> ((list A) * (list A))}
  Test [] A1 A2 -> (@p A1 A2)
  Test [A | Rest] A1 A2 -> (separate-aux Test Rest [A | A1] A2) where (Test A)
  Test [A | Rest] A1 A2 -> (separate-aux Test Rest A1 [A | A2]))

(define separate
  \* separate a list into those that do and don't satisfy a boolean function *\
  {(A --> boolean) --> (list A) --> ((list A) * (list A))}
  Test L -> (separate-aux Test L [] []))

\* Helper Part *\ 

(define symlist-string
  [] -> ""
  [X] -> (str X)
  [X|Xs] -> (str (foldl concat X Xs)))

(define build-cxr-symbol
  { (list symbol) --> symbol }
  [] -> (error "malformed x to build cxr")
  L -> (intern (@s "c" (symlist-string L) "r")))

(define build-cxr-symbols
  { (list (list symbol)) --> (list symbol) }
  [] -> (error "empty list")
  L -> (map (function build-cxr-symbol) L))

(define build-fun-template
  { number --> ((list (list symbol)) * (list (list symbol))) }
  Level -> (build-fun-template- Level [] []))

(define build-fun-template-
  { number --> (list (list symbol)) --> (list (list symbol))
	   --> ((list (list symbol)) * (list (list symbol))) }
  0 Cars Cdrs -> (@p Cars Cdrs)
  N Cars Cdrs -> (let Vars (separate 
			   (/. X (= (head X) a))
			   (cxr-variations N))
	              VCars (build-cxr-symbols (fst Vars))
		      VCdrs (build-cxr-symbols (snd Vars))
		   (build-fun-template-
		    (- N 1) (append VCars Cars) (append VCdrs Cdrs))))

\*(build-fun-template 2)
=> (@p [car cadr caar] [cdr cddr cdar]) *\ 

\* Core Part *\ 

(define build-cxrs
  N -> (let Funs (build-fun-template N)
	    Cars (fst Funs)
	    Cdrs (snd Funs)
	 (do
	  \* create functions *\ 
	  (map (/. Z
		   (eval [define Z X -> (cxr? Z X)]))
	       (append Cars Cdrs))
	  \* declare datatypes *\ 
	  (map (/. X (declare X [[list A] --> A])) Cars)
	  (map (/. X (declare X [[list A] --> [list A]])) Cdrs))))

\* Example *\ 
\*
(0-) (load "build-cxrs.shen")
(1-) (build-cxrs 4)
(2-) (tc+)
(3-) (cddddr [1 2 3 4 5 6 7])
[5 6 7] : (list number)
*\