;; sample macro for s_exp_ocaml.scm
;; version 0.20130406

(define car List.hd)
(define cdr List.tl)
(define cadr (fun (ls) (List.hd (List.tl ls))))
(define caddr (fun (ls) (List.hd (List.tl (List.tl ls)))))
(define cddr (fun (ls) (List.tl (List.tl ls))))
(define cdddr (fun (ls) (List.tl (List.tl (List.tl ls)))))
;;(define for-each List.iter)
;;(define foreach List.iter)
;;(define map List.map)
;;(define reverse List.rev)
;;(define length List.length)
;;(define list-ref List.nth)
;;(define newline Pervasives.print_newline)
;;(define flatten List.flatten)
;;(define cons (fun (el ls) (:: el ls)))
;;(define append (fun (ls1 ls2) (@ ls1 ls2)))
;;(define string-append (lambda (str1 str2) (^ str1 str2)))



(define-syntax
	cond
	(syntax-rules (else)
		((_ (else a1 a2 ...))
			(begin a1 a2 ...))
		((_ (a1 a2 ...))
			(if a1 (begin a2 ...)))
		((_ (a1 a2 ...) b  ...)
			(if a1 (begin a2 ...) (cond b ...)))
		))


(define-syntax
	let1
	(syntax-rules ()
		((_ key val)
			(let ((key val))))
		((_ key val exp1 exp2 ...)
			(let ((key val)) exp1 exp2 ...))
		))


(define-macro list-ec (lambda expr
		(letrec
			(
				(rs (gensym))
				(tmp (gensym))
				(genbody (lambda (src)
					(let (
						(hd (car src))
						(tl (cdr src))
						)
						(if (null? tl)
							`(:= ,rs (:: ,hd (! ,rs)))
							(cond
								((or
									(and (eq? (car hd) 'for) (or (= (length hd) 4) (= (length hd) 5)))
									(and (eq? (car hd) 'for-down) (or (= (length hd) 4) (= (length hd) 5)))
									)
									`(,(car hd) (
										,tmp
										,(if (= (length hd) 4) (caddr hd) 0)
										,(if (= (length hd) 4)
											(cadddr hd)
											`(/ (- ,(cadddr hd) ,(caddr hd)) ,(cadddr (cdr hd)))
											)
										)
										(let ((
											,(cadr hd)
											,(if
												(= (length hd) 4)
												tmp
												`(+ ,(caddr hd) (* ,tmp ,(cadddr (cdr hd)))))
											)) ,(genbody tl)))
									)
								((or
									(and (eq? (car hd) 'map) (= (length hd) 3))
									;;(and (eq? (car hd) 'for-down) (= (length hd) 3))
									)
									`(List.iter
										(lambda (,(cadr hd)) ,(genbody tl))
										;;,(if (eq? (car hd) 'for-down)
										;;	`(reverse ,(caddr hd))
											,(caddr hd)
										;;	)
										)
									)
								((and (eq? (car hd) 'if) (= (length hd) 2))
									`(if ,(cadr hd) ,(genbody tl))
									)
								((and (eq? (car hd) 'let) (= (length hd) 3))
									`(let ((,(cadr hd) ,(caddr hd))) ,(genbody tl))
									)
								(#t
									(error (string-append "list-ec syntax error: " (write-to-string hd))))
									;;(cons hd (genbody tl)))
								))
						)))
				(body (genbody expr))
				)

		`(let
			((,rs (ref '()))) (begin ,body
			(List.rev (! ,rs))))

		)))


(define-syntax
	list-int
	(syntax-rules (..)
		((_ v1 v2 .. v3)
			(if
				(< v1 v2)
				(CommonFunctions.list_range v1 v3 (- v2 v1))
				(CommonFunctions.list_range_down v1 v3 (- v1 v2))
				)
			)
		((_ v1 .. v2)
			(if
				(< v1 v2)
				(CommonFunctions.list_range v1 v2 1)
				(CommonFunctions.list_range_down v1 v2 1)
				)
			)
		((_)
			(list)
			)
		((_ v)
			(list v)
			)
		((_ v1 v2 ...)
			(list v1 v2 ...)
			)
		))

(define-syntax
	list-float
	(syntax-rules (..)
		((_ v1 v2 .. v3)
			(if
				(< v1 v2)
				(CommonFunctions.list_range_float v1 v3 (-. v2 v1))
				(CommonFunctions.list_range_down_float v1 v3 (-. v1 v2))
				)
			)
		((_ v1 .. v2)
			(if
				(< v1 v2)
				(CommonFunctions.list_range_float v1 v2 1.0)
				(CommonFunctions.list_range_down_float v1 v2 1.0)
				)
			)
		((_)
			(list)
			)
		((_ v)
			(list v)
			)
		((_ v1 v2 ...)
			(list v1 v2 ...)
			)
		))






(module CommonFunctions (struct
	(define list_range (ocaml "
		fun begin_num end_num step ->
			let tmp = ref [] in
				(if step = 1 then
					for x = begin_num to end_num do
						tmp := x :: (!tmp)
					done
				else
					for x = 0 to (end_num - begin_num) / step do
						tmp := (begin_num + (x * step)) :: (!tmp)
					done
				);
				List.rev (!tmp);
		"))

	(define list_range_down (ocaml "
		fun begin_num end_num step ->
			let tmp = ref [] in
				(if step = 1 then
					for x = begin_num downto end_num do
						tmp := x :: (!tmp)
					done
				else
					for x = 0 downto (end_num - begin_num) / step do
						tmp := (begin_num + (x * step)) :: (!tmp)
					done
				);

				List.rev (!tmp);
		"))

	(define list_range_float (ocaml "
		fun begin_num end_num step ->
			let tmp = ref [] in
				(if step = 1.0 then
					for x = (int_of_float begin_num) to (int_of_float end_num) do
						tmp := (float_of_int x) :: (!tmp)
					done
				else
					for x = 0 to (int_of_float ((end_num -. begin_num) /. step)) do
						tmp := (begin_num +. ((float_of_int x) *. step)) :: (!tmp)
					done
				);
				List.rev (!tmp);
		"))

	(define list_range_down_float (ocaml "
		fun begin_num end_num step ->
			let tmp = ref [] in
				(if step = 1.0 then
					for x = 0 downto (int_of_float (end_num -. begin_num)) do
						tmp := (begin_num +. (float_of_int x)) :: (!tmp)
					done
				else
					for x = 0 downto (int_of_float ((end_num -. begin_num) /. step)) do
						tmp := (begin_num +. ((float_of_int x) *. step)) :: (!tmp)
					done
				);

				List.rev (!tmp);
		"))



	))






(define-macro compose
	(lambda args
		(letrec
			(
				(make-fargs
					(lambda (ls)
						(if (null? ls) '() (cons (gensym) (make-fargs (cdr ls))))
						))
				(fargs (make-fargs args))
				(make-exp
					(lambda (ls)
						(if (null? ls) 'comp_args (list (car ls) (make-exp (cdr ls))))
						))
				(comp_exp (make-exp fargs))
				)
		`((lambda ,fargs
				(lambda (comp_args) ,comp_exp)
				) . ,args)
		)))


(define-macro with-gensyms (lambda (syms . body)
	`(let
		,(map (lambda (s) `(,s (gensym))) syms)
		. ,body
		)
	))



(define-syntax
	defun
	(syntax-rules ()
		((_ name args)
			(define name (fun args) ())
			)
		((_ name args e1 e2 ...)
			(define name (fun args e1 e2 ...))
			)
		))


;;(define-syntax
;;	list
;;	(syntax-rules ()
;;		((_)
;;			'())
;;		((_ e1)
;;			'(e1))
;;		((_ e1 e2 ...)
;;			'(e1 e2 ...))
;;		))

;;(define-syntax
;;	vector
;;	(syntax-rules ()
;;		((_)
;;			'#())
;;		((_ e1)
;;			'#(e1))
;;		((_ e1 e2 ...)
;;			'#(e1 e2 ...))
;;		))

;;(define-syntax
;;	array
;;	(syntax-rules ()
;;		((_)
;;			'#())
;;		((_ e1)
;;			'#(e1))
;;		((_ e1 e2 ...)
;;			'#(e1 e2 ...))
;;		))


(define-macro defun-varargs (lambda (name fargs . body)
	(letrec (
			(fname (gensym))
			(lenloop
				(lambda (src)
					(if
						(pair? src)
						(if
							(null? src)
							'()
							(cons (car src) (lenloop (cdr src)))
							)
						(begin
							(cons src '())
							;;(error (cons src '()))
							)
						)
					)
				)
			(has-opt (not (list? fargs)))
			(fargs2 (if has-opt (lenloop fargs) fargs))
		)

	`(define ,fname
	(begin
;;	(multi-expressions
		(define-macro ,name (lambda margs 
			(letrec (
					(fname (quote ,fname))
					(argloop (lambda (src1 src2)
							(if (pair? src1)
								(if
									(null? src1)
									'()
									(cons (car src2) (argloop (cdr src1) (cdr src2)))
									)
								`(',src2)
								)
							))
						(param ,(if has-opt `(argloop (quote ,fargs) margs) `margs))
				)

			`(,fname . ,param)))
			)
		(lambda ,fargs2 . ,body )
		))
	)))



(define-macro list-iter-n
	(lambda (f . v-list)
		(let
			(
				(loop (gensym))
				(arg-list (map (lambda (v) (gensym)) v-list))
				(hd-list (map (lambda (v) (gensym)) v-list))
				(tl-list (map (lambda (v) (gensym)) v-list))
				)
			`(letrec
				((,loop
					(fun (f . ,arg-list)
						(match (tuple . ,arg-list)
							((tuple . ,(map (lambda (x) ''()) arg-list)) () '())
							((tuple . ,(map (lambda (hd tl) `(:: ,hd ,tl)) hd-list tl-list)) ()
								(f . ,(map (lambda (hd) hd) hd-list))
								(,loop f
									. ,(map (lambda (tl) tl) tl-list))
								)
							((tuple . ,(map (lambda (x) '_) arg-list)) () (invalid_arg "list-iter-n"))
							)
						)))
				(,loop ,f . ,v-list))
			))
	)




(define-macro list-rev-map-n
	(lambda (f . v-list)
		(let
			(
				(loop (gensym))
				(arg-list (map (lambda (v) (gensym)) v-list))
				(hd-list (map (lambda (v) (gensym)) v-list))
				(tl-list (map (lambda (v) (gensym)) v-list))
				)
			`(letrec
				((,loop
					(fun (f tmp . ,arg-list)
						(match (tuple . ,arg-list)
							((tuple . ,(map (lambda (x) ''()) arg-list)) () tmp)
							((tuple . ,(map (lambda (hd tl) `(:: ,hd ,tl)) hd-list tl-list)) ()
								(,loop f
									(::
										(f . ,(map (lambda (hd) hd) hd-list))
										tmp)
									. ,(map (lambda (tl) tl) tl-list))
									
								)
							((tuple . ,(map (lambda (x) '_) arg-list)) () (invalid_arg "list-map-n"))
							)
						)))
				(,loop ,f '() . ,v-list))
			))
	)



(define-syntax list-map-n
	(syntax-rules ()
		((_ f v)
			(List.rev (list-rev-map-n f v)))
		((_ f v1 v2 ...)
			(List.rev (list-rev-map-n f v1 v2 ...)))
		))


;; 'a list -> 'b list -> ... -> ('a * 'b * ...) list
(define-macro list-combine-n
	(lambda v-list
		(let
			((arg-list (map (lambda (v) (gensym)) v-list)))
			`(list-map-n (fun ,arg-list (tuple . ,arg-list)) . ,v-list)
			)
		))



(define-macro anaphoric-args
	(lambda (name f)
		`(begin
;;		`(multi-expressions
			(define-macro ,name
			(lambda (body . args)
				(letrec
					(
						(gen-argsname
							(lambda (count ls)
								(if (null? ls)
									'()
									(cons
										(string->symbol (string-append "_" (number->string count)))
										(gen-argsname (+ count 1) (cdr ls))))
								))
						(fargs (gen-argsname 1 args))
						)
				`(,(quote ,f)
					(fun ,fargs ,(cons 'begin body))
					. ,args)
				)))
			)
		))


;; accessor for nested arrays
;; [| [||]; [|1;2;3;4|]; [||]; [||]; [||] |].(1).(2)
;;
;;(array-get
;;  '#( '#() '#(1 2 3 4) '#() '#() '#())
;;    1
;;    2)

(define-syntax array-get
	(syntax-rules ()
		((_ ar i)
			(Array.get ar i))
		((_ ar i1 i2 ...)
			(array-get (Array.get ar i1) i2 ...))
		))






;;(defun-varargs append args
;;  (List.flatten args))

;;(defun-varargs string-append args
;;  (String.concat "" args))


(define-macro src->string write-to-string)


;; programming by contract
;;(define-exception Contract_assert_failure ((string * string)))

(type contract_assert_type "Contract_in_assert | Contract_out_assert")
(exception Contract_assert_failure "(contract_assert_type * string)")

;;(contract-fun (v1 v2)
;;	(
;;		(in (< v1 4))
;;		(out result (> result 5)))
;;		exp ...
;;	)

(define-syntax
	contract-fun
	(syntax-rules (in out)
		((_ args ((in in_t) (out result out_t)) exp1 exp2 ...)
			(lambda
				args
				(if in_t
					(let
						((result_tmp (begin exp1 exp2 ...)))
						(let
							((result result_tmp))
							(if out_t result_tmp (raise (Contract_assert_failure (tuple Contract_out_assert (src->string out_t)))))))
					(raise (Contract_assert_failure (tuple Contract_in_assert (src->string in_t))))
					))
			)
		((_ args ((out result out_t) (in in_t)) exp1 exp2 ...)
			(lambda-contract args ((in in_t) (out result out_t)) exp1 exp2 ...)
			)
		((_ args ((in in_t)) exp1 exp2 ...)
			(lambda
				args
				(if in_t
					(begin exp1 exp2 ...)
					(raise (Contract_assert_failure (tuple Contract_in_assert (src->string in_t))))
					))
			)
		((_ args ((out result out_t)) exp1 exp2 ...)
			(lambda
				args
					(let
						((result_tmp (begin exp1 exp2 ...)))
						(let
							((result result_tmp))
							(if out_t result_tmp
								(raise (Contract_assert_failure (tuple Contract_out_assert (src->string out_t))))
								)
							)
						))
			)

		)
	)




(define-macro defun-matched-clauses (lambda funs
	
	(letrec
		(
			(replace-symbol (lambda (ls)
				(map
					(lambda (el)
						(cond
							((symbol? el) '_)
							((and (pair? el) (eq? (car el) 'quote)) el)
							((and (pair? el) (eq? (car el) '::)) el)
							((pair? el) (replace-symbol el))
							(#t el)
							)
						)
					ls
					)
				))

			(get-node-var-list (lambda (var-list ls tmp)
					(cond
						((null? ls)
							(reverse tmp)
							)
						((and (pair? (car ls)) (eq? (car (car ls)) 'quote))
							(get-node-var-list (cdr var-list) (cdr ls) tmp))
						((and (pair? (car ls)) (eq? (car (car ls)) '::))
							(get-node-var-list (cdr var-list) (cdr ls) tmp))
						((pair? (car ls))
							(get-node-var-list (cdr var-list) (cdr ls) tmp))
						((symbol? (car ls))
							(get-node-var-list (cdr var-list) (cdr ls)
							(cons
								(list (car ls) (car var-list))
								tmp
								))
								)
						(#t
							(get-node-var-list (cdr var-list) (cdr ls) tmp))
						)
				))

			(search-var (lambda (var body)
				(let ((rs #f))
					(for-each
						(lambda (el)
							(cond
								((pair? el)
									(if (search-var var el)
										(set! rs #t)))
								((eq? var el)
									(set! rs #t))
								))
						body)
					rs)
				))

			(filter-node-var-list (lambda (var-list body)
				(map
					(lambda (var)
						(if (search-var (car var) body)
							var
							(list '_ (cadr var))
							)
						)
					var-list)
				))

			(f-table (make-hash-table 'eq?))
			(f-name-list '())
			)
		

		(for-each
			(lambda (form)
				(if (hash-table-exists? f-table (car form))
					(hash-table-put! f-table (car form)
						(cons form (hash-table-get f-table (car form)))
						)
					(begin
						(hash-table-put! f-table (car form) (list form))
						(set! f-name-list (cons (car form) f-name-list))
						))
				)
			funs)

		`(multi-expressions
			,@(map (lambda (f-name)
			(let* (
				(var-list
					(map (lambda (el) (gensym)) (cadr (car (hash-table-get f-table f-name))))
					)
				(var-list-length (length var-list))
					)


				(for-each (lambda (el)
					(if (not (eq? (length (cadr el)) var-list-length)) (error "args length failed"))
					)
					(reverse (hash-table-get f-table f-name)))

				
				`(define ,f-name
					(fun ,var-list
						(match (tuple ,@var-list)

							,@(map (lambda (f-el)
									`((tuple
										,@(replace-symbol (cadr f-el))
										) ()
										,(let ((node-var-list (get-node-var-list var-list (cadr f-el) '())))
											(if (null? node-var-list)
												(cons 'begin (cddr f-el))
												`(let
													,(filter-node-var-list node-var-list (cddr f-el))
													,@(cddr f-el))
												))
										)
								
								) (reverse (hash-table-get f-table f-name)))
							)
							))
						)
				)
				(reverse f-name-list))
			)
		)
	))










(set-macro-character #\{ (lambda (p char)
	`(record . ,(read-delimited-list p #\}))
	))

(set-macro-character2 #\# #\# (lambda (p char char2)
	'method-call
	))

(set-macro-character2 #\# #\. (lambda (p char char2)
	'module-ref
	))

(set-macro-character2 #\# #\, (lambda (p char char2)
	`(tuple ,@(read p))
	))