;; This is some experimental code for embedding Haskell style pattern
;; matching into Arc. It uses almkglor's defpat library, available
;; from the Anarki git repo: http://git.nex-3.com/arc-wiki.git
;;
;; -- Ray Myers
;;    http://cadrlife.blogspot.com
;;    http://cadrlife.com
(require "lib/defpat.arc")

;; pcase: similar to the Scala match-case.
(let trans
  (p-m:afn
    (()) '()
    ((x)) `(,x)
    ((x  y . ys))
      (let a (if (isa x 'sym) `',x x)
        `((,a) ,y ,@(self ys))))
  (mac pcase (var . cases)
    `((p-m:fn ,@(trans cases)) ,var)))

;; This is the case example from the Arc tutorial, to show that
;; `pcase' is actually a generalization of `case'.
(def translate (sym)
  (pcase sym 
         apple 'mela 
         onion 'cipolla 
         'che?))


(mac hdef (name . body)
  (let args (uniq)
    `(def ,name ,args (hcase ,args ,@body))))

(= otherwise t)

(mac hcase (xs . cases)
  "Haskell style pattern matching"
    `(apply (p-m:fn ,@(h-trans cases)) ,xs))

(p-m:def guard-trans1
  "Helper for gaurd-trans.
 (gaurd-trans1 '(/ p = a / q = b rest))  =>  ((p a q b) rest)"
  (('/ pred '= con . rest)) (let (x . xs) (guard-trans1 rest) (cons (join (list pred con) x) xs)) 
  (li) (cons nil li))

(def make-call (li)
  (if (and (is 1 (len li)) (alist (car li))) 
      (car li)
      li))

(def bar (li)
  (if (is 0 (pos '/ li))
      (aif (pos '= li) `(/ ,(make-call (cut li 1 it)) ,@(cut li it))
	   li)
      li))

(def guard-trans (li)
  "Helper for h-trans.
 (guard-trans '(/ p = a / q = b rest))  =>  (= (if p a q b) rest)"
  (let (x . xs) (guard-trans1 (bar li))
       (if (no x) xs
	   (join (list '= (cons 'if x)) xs))))

(p-m:def h-trans
  (xs)     (h-trans '() xs)
  (acc ()) acc
  (acc (x)) `(,@acc ,x)
  (acc (x y . ys))
    (let (x y . ys) (guard-trans `(,x ,y . ,ys))
	(if (is x '=)
	    (withs ((bindings . pat) (at-signs acc) pat1 (translate-pattern pat))
	      `(,pat1 (withs ,(translate-bindings bindings)  ,y) ,@(h-trans () ys)))
	    (h-trans `(,@acc ,x) `(,y ,@ys)))))

(def translate-bindings (bindings)
  (let b t
    (map (fn (a) (= b (no b)) (if b (consify a) a)) (translate-pattern bindings))))

(def consify (a)
  (if (acons a) (list 'cons (consify (car a)) (consify (cdr a)))
      a))

(def at-signs (li)
  (foo (process-symbols #\@ li)))

(p-m:def foo
  ((x '@ y . rest))
    (let (z . zs) (foo rest)
	 (let (a . as) (foo (cons y zs))
	      (cons (join a (cons x (cons y z))) as)))
  ((x . rest))
    (let (z . zs) (foo rest)
	 (cons z (cons x zs)))
  ((li)) (cons nil li))

(def translate-pattern (a)
  "(translate-pattern '([a] (b:c)))  =>  ((a) (b . c))"
  (colon-to-dot:process-colons:transform-brackets a))

(def process-colons (li) (process-symbols #\: li))

(def transform-brackets (a)
  "(transform-brackets '([] [x]))  =>  (nil (x))"
  (if (and (acons a) (~dotted a))
      (if (is 'make-br-fn (car a))
          (map transform-brackets (cadr a))
          (map transform-brackets a))
      a))

(def rem-all-but-last (el li)
  "Remove all but the last occurance of el in list."
  (let (x . xs) (split-by el (rev li))
    (if (no xs) li
      (rev (apply join `(,x (,el) ,@xs))))))

(def dot-list (li)
  "Turn list to dotted list."
  (if (no li) ()
      (no (cdr li)) (car li)
      (cons (car li) (dot-list (cdr li)))))

(def colon-to-dot (li)
  "Translate Haskell list notation to Lisp notation.
  (colon-to-dot '(a : b : c))  =>  (a b . c)"
  (if (no (acons li)) li
      (let xs (map colon-to-dot (rem-all-but-last ': li))
        (if (is 2 (len (mem [is ': _] xs)))
              (dot-list (rem ': xs))
            (rem ': xs)))))

(def process-symbols (char li)
  "Takes a list. Breaks apart symbols with `char' in them.
  (process-colons #\\: '(x :x: 4))  =>  '(x : x : 4)"
  (if (no li) ()
    (let (x . xs) li
      (if (dotted li) (process-symbols char `(,x ,(sym char) ,xs))
          (or (no x) (is (sym char) x)) (cons x (process-symbols char xs))
          (isa x 'sym) (join (split-symbol char x) (process-symbols char xs))
          (acons x) (cons (process-symbols char x) (process-symbols char xs))
          (cons x (process-symbols char xs))))))

(def replace (new old seq)
  "This really should be a library call."
  (map [if (iso old _) new _] seq))

(def split-symbol (char s)
  "Break apart a symbol by `char'.
  (split-symbol #\\: 'a:2:1.3:b:)  =>  '(a : 2 : 1.3 : b :)"
  (rem [is '|| _]
       (intersperse (sym char) 
                    (map read 
                         (replace "||" ""
                                  (split-by char (string s)))))))

(def split-by (el seq)
  "Split sequence apart on occurances of el. Similar to perl split.
  (split-by '- '(1 - 2 3 4 - 5 -))  =>  ((1) (2 3 4) (5) nil)"
  (aif (pos el seq)
    (cons (cut seq 0 it) (split-by el (cut seq (+ 1 it))))
      (list seq)))


;; Given the above code, here are bunch of equivelant definitions for
;; a function that takes the union of two sorted lists. Note: that is
;; not what the Arc2 library function `union' does.

(def union (< xs ys)
  (if (no xs) ys
      (no ys) xs
      (with (x (car xs) xt (cdr xs)
             y (car ys) yt (cdr ys))
        (if (< x y) (cons x (union < xt ys))
            (< y x) (cons y (union < xs yt))
            (cons x (union < xt yt))))))

(def union (< xs ys)
  (if (no xs) ys
      (no ys) xs
      (with ((x . xt) xs (y . yt) ys)
        (if (< x y) (cons x (union < xt ys))
            (< y x) (cons y (union < xs yt))
            (cons x (union < xt yt))))))

(def union (< xs ys)
  (pcase `(,xs ,ys)
    (xs ()) xs
    (() ys) ys
    ((x . xt) (y . yt))
      (if (< x y) (cons x (union < xt ys))
          (< y x) (cons y (union < xs yt))
          (cons x (union < xt yt)))))


(def union (< xs ys)
  (hcase `(,xs ,ys)
    xs [] = xs
    [] ys = ys
    (x:xt) (y:yt) = 
      (if (< x y) (cons x (union < xt ys))
          (< y x) (cons y (union < xs yt))
          (cons x (union < xt yt)))))

(def union (< xs ys)
  (hcase `(,xs ,ys)
    xs [] = xs
    [] ys = ys
    (x:xt) (y:yt) / (< x y) = (cons x (union < xt ys))
                  / (< y x) = (cons y (union < xs yt))
                  / otherwise = (cons x (union < xt yt))))

(def union args
  (hcase args
    _ xs [] = xs
    _ [] ys = ys
    < xs@(x:xt) ys@(y:yt) / (< x y) = (cons x (union < xt ys))
                          / (< y x) = (cons y (union < xs yt))
                          / otherwise = (cons x (union < xt yt))))

(hdef union 
  _ xs [] = xs
  _ [] ys = ys
  < xs@(x:xt) ys@(y:yt) / (< x y) = (cons x (union < xt ys))
                        / (< y x) = (cons y (union < xs yt))
                        / otherwise = (cons x (union < xt yt)))