(* vim: textwidth=0:noexpandtab:foldmethod=marker:foldmarker={{{,}}}:foldlevel=1
 *)

exception Lookup_Failure of string

(* {{{1 misc function *)
(* {{{2 mapM :: (a -> m b) -> [a] -> m [b])
 * リストに対して与えられたアクションを順次実行していく。
 *)
let rec mapM f xss		= ( match xss with
				  | []			-> ()
				  | x::xs		-> ( f x );( mapM f xs )
				  )
;;

(* {{{2 deleteBy :: (a -> b -> Bool) -> b -> [a] -> [a]
 * あたえられた関数と定数を使い、条件にあう要素を先頭のひとつだけ削除する。
 * 条件にあう要素が見つかればそれ以降はチェックしない。
 *)
let rec deleteBy f y xss	= ( match xss with
				  | []			-> []
				  | ( k, v ) :: xs	-> if f y k
							    then xs
							    else ( k, v )::( deleteBy f y xs )
				  )
;;

(* {{{2 enumFromTo :: a -> a -> [a]
 * nからmまでの連番を作る。
 *)
let rec enumFromTo n m		= if n > m
				   then []
				   else n :: ( enumFromTo ( n + 1 ) m )
;;

(* {{{2 zipWith :: (a -> b -> c) -> [a] -> [b] -> [c]
 * 二つのリストをあたえられた関数でまとめながら一つのリストにする。
 *)
let rec zipWith f xss yss	= ( match ( xss, yss ) with
				  |  ( _, [] )		-> []
				  | ( [], _ )		-> []
				  | ( x::xs, y::ys )	-> ( f x y ) :: ( zipWith f xs ys )
				  )
;;

(* {{{2 Maybe a = Nothing | Just a
 * Maybeモナドもどき。
 *)
type 'a maybe			= Nothing
				| Just of 'a
;;

(* {{{2 catMaybes :: [Maybe a] -> a
 * MaybeリストからNothingを消去し、圧縮する。
 *)
let rec catMaybes xss		= ( match xss with
				  | Just x :: xs	-> x :: catMaybes xs
				  | Nothing :: xs	-> catMaybes xs
				  | []			-> []
				  )
;;

(* {{{2 (>>=) :: m a -> (a -> m b) -> m b
 * アロー演算子もどき。
 *)
let (>>=) m1 m2			= ( match m1 with
				  | Just x		-> m2 x
				  | Nothing		-> Nothing
				  )
;;

(* {{{2 (>>) :: m a -> m b -> m b
 * アロー演算子もどき。
 *)
let (>>) m1 m2			= ( match m1 with
				  | Just _		-> m2
				  | Nothing		-> Nothing
				  )
;;
(* }}}1 misc function *)

(* {{{1 exp *)
(* {{{2 type exp *)
type exp	= IntLit of int
		| Plus of exp * exp
		| Times of exp * exp
		| Minus of exp * exp
		| Divids of exp * exp
		| BoolLit of bool
		| If of exp * exp * exp
		| Eq of exp * exp
		| Lt of exp * exp
		| Gt of exp * exp
		| Var of string
		| Let of string * exp * exp
		| LetRec of string * string * exp * exp
		| Fun of string * exp
		| App of exp * exp
		| Empty
		| Cons of exp * exp
		| Head of exp
		| Tail of exp
		| Match of exp * ( ( exp * exp ) list )
;;
(* }}}1 exp *)

(* {{{1 value *)
(* {{{2 type value *)
type value	= IntVal of int
		| BoolVal of bool
		| ListVal of value list
		| FunVal of string * exp * ( ( string * value ) list )
		| RecFunVal of string * string * exp * ( ( string * value ) list )
;;
(* }}}1 value *)


(* {{{1 print *)
(* {{{2 print_exp :: -> exp -> ()
 * デバッグ用簡易出力
 *)
let print_exp e		= ( match e with
			  | IntLit( n )			-> print_string "Lit "; print_int n
			  | Plus( _, _ )		-> print_string "Plus"
			  | Times( _, _ )		-> print_string "Times"
			  | Minus( _, _ )		-> print_string "Minus"
			  | Divids( _, _ )		-> print_string "Divids"
			  | BoolLit( true )		-> print_string "Lit T"
			  | BoolLit( false )		-> print_string "Lit F"
			  | If( _, _, _ )		-> print_string "If"
			  | Eq( _, _ )			-> print_string "Eq"
			  | Lt( _, _ )			-> print_string "Lt"
			  | Gt( _, _ )			-> print_string "Gt"
			  | Var( s )			-> print_string "Var "; print_string s
			  | Let( s, _, _ )		-> print_string "Let "; print_string s
			  | LetRec( _, s, _, _ )	-> print_string "Let "; print_string s
			  | Fun( s, _ )			-> print_string "Fun "; print_string s
			  | App( _, _ )			-> print_string "App"
			  | Empty			-> print_string "[]"
			  | Cons( _, _ )		-> print_string "Cons"
			  | Head( _ )			-> print_string "Head"
			  | Tail( _ )			-> print_string "Tail"
			  | Match( _, _ )		-> print_string "Match"
			  )
;;

(* {{{2 print_value :: value -> ()
 * デバッグ用簡易出力
 *)
let rec print_value v	= ( match v with
			  | IntVal( n )			-> print_int n
			  | BoolVal( true )		-> print_string "T"
			  | BoolVal( false )		-> print_string "F"
			  | FunVal( s, _, _ )		-> print_string "fun of "
			  				 ; print_string s
			  | RecFunVal( f, s, _, _ )	-> print_string "rec fun of "
			  				 ; print_string s
			  				 ; print_string " named "
			  				 ; print_string f
			  | ListVal( x::xs )		-> print_string "[ "
			  				 ; print_value x
							 ; mapM ( fun y -> print_string "; "; print_value y ) xs
			  				 ; print_string " ]"
			  | ListVal( [] )		-> print_string "[]"
			  )
;;

(* {{{2 print_env :: env -> ()
 * デバッグ用簡易出力
 *)
let print_env ( k, v )	= print_string "("
			; print_string k
			; print_string ","
			; print_value v
			; print_string ") "
;;

(* {{{2 pretty_print_exp :: exp -> ()
 * OCamlの文法にあわせた出力。
 * OCamlでそのまま実行できる...はず。
 *)
let pretty_print_exp e	= let rec pretty_print_exp2 e n =
			  let print_2op s e1 e2		= print_string "( "
			  				; pretty_print_exp2 e1 n
			  				; print_string s
			  				; pretty_print_exp2 e2 n
			  				; print_string " )"
			  in let spaces n		= mapM ( fun _ -> print_string " " ) ( enumFromTo 1 n )
			  in ( match e with
			     | IntLit( m )		-> print_int m
			     | Plus( e1, e2 )		-> print_2op " + " e1 e2
			     | Times( e1, e2 )		-> print_2op " * " e1 e2
			     | Minus( e1, e2 )		-> print_2op " - " e1 e2
			     | Divids( e1, e2 )		-> print_2op " / " e1 e2
			     | BoolLit ( true )		-> print_string "true"
			     | BoolLit ( false )	-> print_string "false"
			     | If( e1, e2, e3 )		-> print_string "if "; pretty_print_exp2 e1 n; print_string "\n"
			     				 ; spaces n; print_string "then "; pretty_print_exp2 e2 ( n + 1 ); print_string "\n"
			           			 ; spaces n; print_string "else "; pretty_print_exp2 e3 ( n + 1 )
			     | Eq( e1, e2 )		-> print_2op " = " e1 e2
			     | Lt( e1, e2 )		-> print_2op " < " e1 e2
			     | Gt( e1, e2 )		-> print_2op " > " e1 e2
			     | Var( s )			-> print_string s
			     | Let( s, e1, e2 )		-> print_string ( "let " ^s^ " = " ); pretty_print_exp2 e1 n; print_string "\n"
			     				 ; spaces n; print_string " in "; pretty_print_exp2 e2 ( n + 1 )
			     | LetRec( f, s, e1, e2 )	-> print_string ( "let rec " ^f^ " " ^s^ " = " ); pretty_print_exp2 e1 n; print_string "\n"
			     				 ; spaces n; print_string " in "; pretty_print_exp2 e2 ( n + 1 )
			     | Fun( s, e1 )		-> print_string ( "fun " ^s^ " -> " ); pretty_print_exp2 e1 n
			     | App( e1, e2 )		-> print_string "( "; pretty_print_exp2 e1 n; print_string " ) "
			           			 ; print_string "( "; pretty_print_exp2 e2 n; print_string " )"
			     | Empty			-> print_string "[]"
			     | Cons( e1, e2 )		-> print_2op " :: " e1 e2
			     | Head( e1 )		-> print_string "List.hd( "; pretty_print_exp2 e1 n; print_string " )"
			     | Tail( e1 )		-> print_string "List.tl( "; pretty_print_exp2 e1 n; print_string " )"
			     | Match( e1, es )		-> print_string "match "; pretty_print_exp2 e1 n; print_string " with"
			     				 ; mapM	( fun ( e2, e3 )	-> print_string "\n"
			           							 ; spaces n
			     								 ; print_string "| "
			     								 ; pretty_print_exp2 e2 n
			     								 ; print_string " -> "
			     								 ; pretty_print_exp2 e3 n ) es
			     )
			in pretty_print_exp2 e 1
				
;;

(* {{{2 pretty_print_value :: value -> ()
 * OCamlの文法にあわせた出力。
 * OCamlでそのまま実行できる...はず。
 *)
let pretty_print_value v
			= ( match v with
			  | IntVal( n )			-> print_int n
			  | BoolVal( true )		-> print_string "true"
			  | BoolVal( false )		-> print_string "false"
			  | FunVal( s, e1, env )	-> print_string "fun "
			  				 ; print_string s
			  				 ; print_string " -> "
			  				 ; pretty_print_exp e1
			  				 ; print_string "(* env is "
			  				 ; mapM print_env env
							 ; print_string " *)"
			  | RecFunVal( f, s, e1, env )
			  				-> print_string "let "
			  				 ; print_string f
			  				 ; print_string " "
			  				 ; print_string s
			  				 ; print_string " = "
			  				 ; pretty_print_exp e1
			  				 ; print_string "(* env is "
			  				 ; mapM print_env env
							 ; print_string " *)"
			  | ListVal( x::xs )		-> print_string "[ "
			  				 ; print_value x
							 ; mapM ( fun y -> print_string "; "; print_value y ) xs
			  				 ; print_string " ]"
			  | ListVal( [] )		-> print_string "[]"
			  )
;;
(* }}}1 print *)

(* {{{1 env *)
(* {{{2 emptyenv :: () -> env
 * 空の環境
 *)
let emptyenv ()		= []
;;

(* {{{2 ext :: string -> value -> env -> env
 * 環境の拡張。
 * 引数の順番が使いにくかったので変更した。 
 *)
let ext x v env		= ( x, v ) :: ( deleteBy ( = ) x env )
;;

(* {{{2 lookup :: string -> env -> value
 * lookup
 * キーがなければLookup_Failureをraiseする。
 *)
let rec lookup x env	= ( match env with
			  | []			-> raise ( Lookup_Failure x )
			  | ( y, v )::tl	-> if x = y
						    then v
						    else lookup x tl
			  )
;;
(* }}}1 env *)

exception Wrong_Value
exception Unknown_Expression of exp
exception Not_Implement
exception Pattern_Not_Found

(* {{{1 eval *)
let rec eval e env	=
			  (* {{{2 intop :: ( a -> a -> a ) -> exp -> exp -> value
			   * 汎用二項整数の関数 : IntVal版
			   * + - * / などの二項算術関数などに
			   *)
			  let intop f e1 e2 env		= let v2 = eval e2 env		(* OCaml's order *)
							  in let v1 = eval e1 env	(* OCaml's order *)
				  			  in ( match ( v1, v2 ) with
							  | ( IntVal( n1 ), IntVal( n2 ) )	-> IntVal( f n1 n2 )
							  | _					-> raise Wrong_Value
			  				  )
			  (* {{{2 boolop :: ( a -> a -> a ) -> exp -> exp -> value
			   * 汎用二項整数の関数 : BoolVal版
			   * < = > などに
			   *)
			  in let boolop f e1 e2 env	= let v2 = eval e2 env		(* OCaml's order *)
							  in let v1 = eval e1 env	(* OCaml's order *)
				  			  in ( match ( v1, v2 ) with
							  | ( IntVal( n1 ), IntVal( n2 ) )	-> BoolVal( f n1 n2 )
							  | _					-> raise Wrong_Value
			  				  )
			  (* {{{2 listCmp :: (a -> b -> bool) -> [a] -> [b] -> bool
			   * valueの比較用
			   * リストの比較。
			   *)
			  in let rec listCmp f xss yss	= ( match ( xss, yss ) with
							  | ( x::xs, y::ys )	when f x y	-> listCmp f xs ys
							  | ( [], [] )				-> true
							  | _					-> false
							  )
			  (* {{{2 eq :: value -> value -> bool
			   * valueの比較用
			   * 関数以外のvalueを比較する。
			   * listの比較に再起が必要なのでrec。
			   *)
			  in let rec eq v1 v2		= ( match ( v1, v2 ) with
							  | ( IntVal( n1 ), IntVal( n2 ) )	-> n1 = n2
							  | ( BoolVal( b1 ), BoolVal( b2 ) )	-> b1 = b2
							  | ( ListVal( l1 ), ListVal( l2 ) )	-> listCmp eq l1 l2
							  | _					-> raise Wrong_Value
							  )
			  (* {{{2 binds :: exp -> value -> env -> env maybe
			   * パターンマッチ用
			   * eとvが同じ構造で、対応する定数が等しいときにかぎり、
			   * eに表れるVarすべてに、対応するvの値を束縛した環境を返す。
			   * それ以外ではNothingを返す。
			   *
			   *)
			  in let rec binds e v env	= ( match ( e, v ) with
			  				  | ( IntLit( ne ), IntVal( nv ) )	when  ne = nv -> Just env
							  | ( BoolLit( be ), BoolVal( bv ) )	when  be = bv -> Just env
							  | ( Empty, ListVal( [] ) )		-> Just env
							  | ( Cons( he, te ), ListVal( hv::tv ) )
							  					-> Just env >>= binds he hv >>= binds te ( ListVal( tv ) )
							  | ( Var( x ), IntVal( _ ) )		-> Just ( ext x v env )
							  | ( Var( x ), BoolVal( _ ) )		-> Just ( ext x v env )
							  | ( Var( x ), ListVal( _ ) )		-> Just ( ext x v env )
							  | _					-> Nothing
			  				  )
			  (* {{{2 matches value -> ( exp * exp ) list -> exp
			   * パターンマッチ用
			   * パターンリストを順次bindsに喰わせ、マッチしたものだけをevalする。
			   * 遅延評価がないからmapやらcatMaybesなどがつかえない...orz
			   *)
			  in let rec matches v1 ess	= ( match ess with
							  | ( ( e2, e3 )::es )			-> ( match binds e2 v1 env with
							  					   | Just env1			-> eval e3 env1
												   | Nothing			-> matches v1 es
												   )
							  | []					-> raise Pattern_Not_Found
			  				  )
			  (* {{{2 eval body *)
			  in ( match e with
			     | Var( x )			-> lookup x env
			     | IntLit( n )		-> IntVal( n )
			     | Plus( e1, e2 )		-> intop ( + ) e1 e2 env
			     | Times( e1, e2 )		-> intop ( * ) e1 e2 env
			     | Minus( e1, e2 )		-> intop ( - ) e1 e2 env
			     | Divids( e1, e2 )		-> intop ( / ) e1 e2 env
			     | Eq( e1, e2 )		-> let v2 = eval e2 env		(* OCaml's order *)
							   in let v1 = eval e1 env	(* OCaml's order *)
							   in BoolVal( eq v1 v2 )
			     | Lt( e1, e2 )		-> boolop ( < ) e1 e2 env
			     | Gt( e1, e2 )		-> boolop ( > ) e1 e2 env
			     | BoolLit( b )		-> BoolVal( b )
			     | If( e1, e2, e3 )		-> ( match ( eval e1 env ) with
			     				   | BoolVal( true )			-> eval e2 env
			     				   | BoolVal( false )			-> eval e3 env
			     				   | _					-> raise Wrong_Value
							   )
			     | Let( x, e1, e2 )		-> let v1 = eval e1 env
			     				   in eval e2 ( ext x v1 env )
			     | LetRec( f, x, e1, e2 )	-> let v1 = RecFunVal( f, x, e1, env )
			     				   in eval e2 ( ext f v1 env )
			     | Fun( x, e1 )		-> FunVal( x, e1, env )
			     | App( e1, e2 )		-> let arg = eval e2 env
			     				   in let funpart = eval e1 env
			     				   in ( match funpart with
							      | FunVal( x, body, env1 )		-> eval body ( ( ext x arg ) env1 )
			     				      | RecFunVal( f, x, body, env1 )	-> let env2 = ext f funpart env1
							        				   in let fv = FunVal( x, body, env2 )
							        				   in eval body ( ( ext x arg ) ( ext f fv env1 ) )
			     				      | _				-> raise Wrong_Value
							      )
			     | Empty			-> ListVal( [] )
			     | Cons( e1, e2 )		-> ( match ( eval e1 env, eval e2 env ) with
			     				   | ( v1, ListVal( v2 ) )		-> ListVal( v1 :: v2 )
			     				   | _					-> raise Wrong_Value
							   )
			     | Head( e1 )		-> ( match ( eval e1 env ) with
			     				   | ListVal( v1 )			-> List.hd ( v1 )
			     				   | _					-> raise Wrong_Value
							   )
			     | Tail( e1 )		-> ( match ( eval e1 env ) with
			     				   | ListVal( v1 )			-> ListVal( List.tl ( v1 ) )
			     				   | _					-> raise Wrong_Value
							   )
			     | Match( e1, es )		-> matches ( eval e1 env ) es
			     )
;;
(* }}}1 eval *)

(* {{{1 testParts *)
(* {{{2 list1 = [ 0, 1, 2, 3 ]
 *)
let list1	= Cons	( IntLit 0
			, Cons	( IntLit 1
				, Cons	( IntLit 2
					, Cons	( IntLit 3
						, Empty
						)
					)
				)
			)
;;

(* {{{2 list2 = [ 0, 1, 2, 4 ]
 *)
let list2	= Cons	( IntLit 0
			, Cons	( IntLit 1
				, Cons	( IntLit 2
					, Cons	( IntLit 4
						, Empty
						)
					)
				)
			)
;;

(* {{{2 list3 = [ 0, 1, 2 ]
 *)
let list3	= Cons	( IntLit 0
			, Cons	( IntLit 1
				, Cons	( IntLit 2
					, Empty
					)
				)
			)
;;

(* {{{2 sCmb = (\x y z -> (x z) (y z))
 * いわゆるSコンビネータ
 *)
let sCmb	= Fun	( "x"
			, Fun	( "y"
				, Fun	( "z"
					, App	( App	( Var "x"
							, Var "z"
							)
						, App	( Var "y"
							, Var "z"
							)
						)
					)
				)
			)
;;

(* {{{2 kCmb = (\x _ -> x)
 * いわゆるKコンビネータ
 *)
let kCmb	= Fun	( "x"
			, Fun	( "y"
				, Var "x"
				)
			)
;;

(* {{{2 iCmb = (\x -> x)
 * いわゆるIコンビネータ
 *)
let iCmb	= Fun	( "x"
			, Var "x"
			)
;;

(* {{{2 yCmb = (\f -> (\p -> f (p p)) (\p -> f (p p)))
 * いわゆるYコンビネータ
 *)
let yCmb	= Fun	( "f"
			, App	( Fun	( "p"
					, App	( Var "f"
						, Fun	( "a"
							, App	( App	( Var "p"
									, Var "p"
									)
								, Var "a"
								)
							)
						)
					)
				, Fun	( "p"
					, App	( Var "f"
						, Fun	( "a"
							, App	( App	( Var "p"
									, Var "p"
									)
								, Var "a"
								)
							)
						)
					)
				)
			)
;;

(* {{{2 length
 * listの長さを返す
 *)
let length	= LetRec( "length"
			, "xss"
			, If	( Eq	( Var "xss", Empty )
				, IntLit 0
				, Plus	( IntLit 1
					, App	( Var "length"
						, Tail	( Var "xss" )
						)
					)
				)
			, Var "length"
			)
;;

(* {{{2 sum
 * listの和を返す
 *)
let sum		= LetRec( "sum"
			, "xss"
			, If	( Eq	( Var "xss", Empty )
				, IntLit 0
				, Plus	( Head	( Var "xss" )
					, App	( Var "sum"
						, Tail	( Var "xss" )
						)
					)
				)
			, Var "sum"
			)
;;

(* {{{2 map
 * listの各要素に関数を適応させる
 *)
let map		= LetRec( "map"
			, "f"
			, Fun	( "xss"
				, If	( Eq	( Var "xss", Empty )
					, Empty
					, Cons	( App	( Var "f"
							, Head	( Var "xss" )
							)
						, App	( App	( Var "map"
								, Var "f"
								)
							, Tail	( Var "xss" )
							)
						)
					)
				)
			, Var "map"
			)
;;

(* {{{2 pmap
 * パターンマッチを使ったmap
 *)
let pmap	= LetRec( "map"
			, "f"
			, Fun	( "xss"
				, Match	( Var "xss"
					, [ Cons( Var "x", Var "xs" )
						, Cons	( App	( Var "f"
								, Var "x"
								)
							, App	( App	( Var "map"
									, Var "f"
									)
								, Var "xs"
								)
							)
					  ; Empty
						, Empty
					  ]
					)
				)
			, Var "map"
			)
;;

(* }}}1 testParts *)

(* {{{1 testCase *)
(* {{{2 testCase: スコープのテスト *)
let testCase	= Let	( "x"
			, IntLit 1
			, Let	( "f"
				, Fun	( "y"
					, Plus( Var "x", Var "y" )
					)
				, Let	( "x"
					, IntLit 2
					, App	( Var "f"
						, Plus( Var "x", IntLit 3 )
						)
					)
				)
			)
;;

(* {{{2 skki: skk=iになるか。Funなどのテスト *)
let skki	= Let	( "s"
			, sCmb
			, Let	( "k"
				, kCmb
				, Let	( "i"
					, iCmb
					, Eq	( App	( App	( App	( Var "s", Var "k" )
								, Var "k"
								)
							, IntLit 42
							)
						, App	( Var "i"
							, IntLit 42
							)
						)
					)
				)
			)
;;

(* {{{2 cmbFact: Yコンビネータを使った階乗 *)
let cmbFact	= Let	( "y"
			, yCmb
			, Let	( "fact"
				, Fun	( "f"
					, Fun	( "n"
						, If	( Eq	( Var "n", IntLit 0 )
							, IntLit 1
							, Times ( Var "n"
								, App	( Var "f"
									, Minus	( Var "n"
										, IntLit 1
										)
									)
								)
							)
						)
					)
				, App	( App	( Var "y"
						, Var "fact"
						)
					, IntLit 5
					)
				)
			)
;;

(* {{{2 recFact: 再起関数による階乗 *)
let recFact	= LetRec( "fact"
			, "x"
			, If	( Eq	( Var "x", IntLit 0 )
				, IntLit 1
				, Times	( Var "x"
					, App	( Var "fact"
						, Minus	( Var "x"
							, IntLit 1
							)
						)
					)
				)
			, App	( Var "fact"
				, IntLit 5
				)
			)
;;

(* {{{2 sameList: リストの比較。trueになる場合 *)
let sameList	= Let	( "xs"
			, list1
			, Let	( "ys"
				, list1
				, Eq	( Var "xs", Var "ys" )
				)
			)
;;

(* {{{2 diffList: リストの比較。falseになる場合 *)
let diffList	= Let	( "xs"
			, list1
			, Let	( "ys"
				, list2
				, Eq	( Var "xs", Var "ys" )
				)
			)
;;

(* {{{2 nestedList: ネストしたリストのテスト *)
let nestedList	= Cons	( list1
			, Cons	( list2
				, Empty
				)
			)
;;

(* {{{2 sameList2: ネストしたリストの比較。trueになる場合 *)
let sameList2	= Let	( "xss"
			, Cons	( list1
				, Cons	( list2
					, Empty
					)
				)
			, Let	( "yss"
				, Cons	( list1
					, Cons	( list2
						, Empty
						)
					)
				, Eq	( Var "xss", Var "yss" )
				)
			)
;;

(* {{{2 diffList2: ネストしたリストの比較。falseになる場合 *)
let diffList2	= Let	( "xss"
			, Cons	( list1
				, Cons	( list2
					, Empty
					)
				)
			, Let	( "yss"
				, Cons	( list1
					, Cons	( list3
						, Empty
						)
					)
				, Eq	( Var "xss", Var "yss" )
				)
			)
;;

(* {{{2 lengthTest: lengthのテスト *)
let lengthTest	= Let	( "length"
			, length
			, App	( Var "length"
				, list1
				)
			)
;;

(* {{{2 sumTest: sumのテスト *)
let sumTest	= Let	( "sum"
			, sum
			, App	( Var "sum"
				, list1
				)
			)
;;

(* {{{2 mapTest: mapのテスト *)
let mapTest	= Let	( "map"
			, map
			, Let	( "double"
				, Fun	( "x"
					, Times	( IntLit 2
						, Var "x"
						)
					)
				, App	( App	( Var "map"
						, Var "double"
						)
					, list1
					)
				)
			)
;;

(* {{{2 pmapTest: pmapのテスト *)
let pmapTest	= Let	( "pmap"
			, pmap
			, Let	( "double"
				, Fun	( "x"
					, Times	( IntLit 2
						, Var "x"
						)
					)
				, App	( App	( Var "pmap"
						, Var "double"
						)
					, list1
					)
				)
			)
;;

(* {{{2 matchTest1: パターンマッチのテスト *)
let matchTest1	= Let	( "f"
			, Fun	( "x"
				, Match	( Var "x"
					, [ IntLit 0	, IntLit 0
					  ; IntLit 1	, IntLit 0
					  ; Var "x"	, Divids( IntLit 12
					  			, Times	( Var "x"
									, Plus	( Var "x"
										, IntLit 1
										)
									)
								)
					  ]
					)
				)
			, Let	( "map"
				, map
				, App	( App	( Var "map"
						, Var "f"
						)
					, list1
					)
				)
			)
;;

(* {{{2 matchTest2: パターンマッチのテスト。より複雑に *)
let matchTest2	= Match	( list1
			,[ Cons	( IntLit 0
				, Cons	( Var "a"
					, Cons	( IntLit 2
						, Cons	( Var "b"
							, Var "c"
							)
						)
					)
				) , Cons( Var "a", Cons( Var "b", Var "c" ) )
			 ; Var "_", Empty
			 ]
			)
;;

(* {{{2 matchSum1: パターンマッチを使ったsumのテスト。 *)
let matchSum1	= LetRec( "matchSum1"
			, "xss"
			, Match	( Var "xss"
				, [( Empty			, IntLit 0 )
				  ; Cons( Var "x", Var "xs" )	, Plus	( Var "x"
									, App	( Var "matchSum1"
										, Var "xs"
										)
				  					)
				  ]
				)
			, App	( Var "matchSum1"
				, list1
				)
			)
;;

(* {{{2 matchSum2: パターンマッチを使ったsumのテスト。別ヴァージョン *)
let matchSum2	= LetRec( "matchSum2"
			, "xss"
			, Match	( Var "xss"
				, [ Empty			, IntLit 0
				  ; Cons( Var "x", Empty )	, Var "x"	
				  ; Var "_"			, Plus	( Head	( Var "xss" )
									, App	( Var "matchSum2"
										, Tail	( Var "xss" )
										)
				  					)
				  ]
				)
			, App	( Var "matchSum2"
				, list1
				)
			)
;;

(* {{{2 rsum: 再起的なsum。型がないのでこういうことも可能。 *)
let rsum	= LetRec( "rsum"
			, "xss"
			, Match	( Var "xss"
				, [ Empty					, IntLit 0
				  ; Cons( Empty, Var "xs" )			, App	( Var "rsum"
											, Var "xs"
				  							)
				  ; Cons( Cons( Var "y", Var "ys" ), Var "xs" )	, Plus	( Var "y"
											, Plus	( App	( Var "rsum"
													, Var "ys"
													)
												, App	( Var "rsum"
													, Var "xs"
													)
												)
				  							)
				  ; Cons( Var "x", Var "xs" )			, Plus	( Var "x"
											, App	( Var "rsum"
												, Var "xs"
												)
				  							)
				  ]
				)
			, App	( Var "rsum"
				, Cons	( list1
					, Cons	( IntLit 2
						, Cons	( list2
							, Empty
							)
						)
					)
				)
			)
;;
(* }}}1 testCase *)

(* テスト用。
 * isPureはpretty_print_expしたものが、本物のOcamlでも動くかどうか。
 * trueのやつは出力をもう一度ocamlに通すことで正しい値かチェックできる。
 * falseのやつは実際に目で見て確かめるしかない。
 * $ ocaml miniOcaml.ml > result.ml
 * $ ocaml
 *         Objective Caml version 3.10.2
 *
 * # #use "result.ml";;
 * - : bool = true
 * - : bool = true
 *    ...
 *)
let testIt exp isPure	= print_string "\n"
			; if isPure then () else print_string "(*\n"
			; print_string "if "
			; pretty_print_value ( eval exp ( emptyenv () ) )
			; print_string " = "
			; pretty_print_exp exp
			; print_string "\n"
			; print_string " then print_string \"OK\n\""
			; print_string " else print_string \"NG\n\""
			; print_string ";;\n"
			; if isPure then () else print_string "*)\n"
;;

testIt testCase true;;
testIt sameList true;;
testIt diffList true;;
testIt nestedList true;;
testIt sameList2 true;;
testIt diffList2 true;;
testIt skki true;;
testIt cmbFact false;;	(* Yコンビネータがうまく行かない *)
testIt recFact true;;
testIt lengthTest true;;
testIt sumTest true;;
testIt mapTest true;;
testIt pmapTest true;;
testIt matchTest1 true;;
testIt matchTest2 true;;
testIt rsum false;;	(* 要素の型が違うリストを作っている *)