packages feed

zot 0.0.1 → 0.0.2

raw patch · 13 files changed

+297/−515 lines, 13 files

Files

LICENSE view
@@ -1,4 +1,4 @@-Copyright (c) 2010, Yoshikuni Jujo+Copyright (c) 2011, Yoshikuni Jujo All rights reserved.  Redistribution and use in source and binary forms, with or without
+ README view
@@ -0,0 +1,7 @@+implement Zot by Haskell++Zot is purely functional language.+Read here ( http://semarch.linguistics.fas.nyu.edu/barker/Iota/zot.html )++Now, source cords are dirty.+I will clean later.
− src/AddEcho.hs 
@@ -1,7 +0,0 @@-module AddEcho ( main ) where--import System.Environment--main args = do---	args <- getArgs-	interact (++ concat args)
src/LambdaToSki.hs view
@@ -1,77 +1,81 @@ module LambdaToSki ( main ) where -import SKI ( mkski, Rec( .. ), fromInt, out, readChurch )-import ReadLambda ( readLambda, showSKI )+import Parse ( Parse, spot, token, eof, ( >*> ), alt, build, list1, recL1 )+import Data.Char ( isLower, isAlphaNum )  main :: IO ()-main = interact lambdaToSKI--fromLambda :: String -> Rec a-fromLambda = mkski . showSKI . readLambda--lambdaToSKI :: String -> String-lambdaToSKI = showSKI . readLambda--mulString = "\\x y -> x ( y ( \\g f xx -> f ( g f xx ) ) ) ( \\f x -> x )"--mul :: Rec a -> Rec a -> Rec a-mul x y = out ( out ( fromLambda mulString ) x ) y+main = interact $ show . lambdaToSki . readLambda -zero :: Rec a-zero = fromLambda "\\f x -> x"+data Lambda = Var String | Apply Lambda Lambda | Fun String Lambda | S | K | I -suc :: Rec a -> Rec a-suc = out ( fromLambda "\\g f x -> f ( g f x )" )+instance Show Lambda where+	show S			= "s"+	show K			= "k"+	show I			= "i"+	show ( Apply f a )	= "`" ++ show f ++ show a+	show ( Fun p e )	= "(fun " ++ p ++ " " ++ show e ++ ")"+	show ( Var v )		= "(var " ++ v ++ ")" -two = suc ( suc zero )-three = suc two+onlySKI :: Lambda -> Bool+onlySKI S		= True+onlySKI K		= True+onlySKI I		= True+onlySKI ( Apply f a )	= onlySKI f && onlySKI a+onlySKI _		= False -mul', zero', suc', two' :: String-mul' = lambdaToSKI mulString-zero' = lambdaToSKI "\\f x -> x"-suc' = lambdaToSKI "\\g f x -> f ( g f x)"-two' = apply suc' $ apply suc' zero'-three' = apply suc' two'+makeFun :: [ String ] -> Lambda -> Lambda+makeFun [ p ] ex	= Fun p ex+makeFun ( p : ps ) ex	= Fun p $ makeFun ps ex+makeFun _ _		= error "makeFun error: need 1 parameter at least" -apply :: String -> String -> String-apply f a = '`' : f ++ a+lambdaToSki :: Lambda -> Lambda+lambdaToSki ( Fun x e )		= out x e+lambdaToSki ( Apply f a )	= Apply ( lambdaToSki f ) ( lambdaToSki a )+lambdaToSki _			= error "lambdaToSki error" -cons, car, cdr :: String-cons = "\\s b f -> f s b"-car = "\\p -> p ( \\x y -> x )"-cdr = "\\p -> p ( \\x y -> y )"+out :: String -> Lambda -> Lambda+out _ e+	| onlySKI e	= Apply K e+out x0 v@( Var x1 )+	| x1 == x0	= I+	| otherwise	= Apply K v+out x0 ( Apply f a )	= Apply ( Apply S  $ out x0 f ) $ out x0 a+out x0 ( Fun x1 e )+	| x0 == x1	= Apply K $ out x0 e+	| otherwise	= out x0 $ out x1 e+out _ _			= error "never occur" -true, false :: String-true = "\\x y -> x"-false = "\\x y -> y"+readLambda :: String -> Lambda+readLambda = fst . fst . head . ( parseLambda >*> eof ) . lexer -getBool :: Rec a -> Bool-getBool x = let Bool b = out ( out x ( Bool True ) ) ( Bool False ) in b+parseLambda :: Parse String Lambda+parseLambda = parseApply `alt` parseFun -getIntList :: Rec a -> [ Int ]-getIntList lst---	| out ( out lst ( Bool True ) ) ( Bool False ) == Bool False	= [ ]-	| isFalse lst							= [ ]-	| otherwise							=-		fromInt ( readChurch ( out lst ( fromLambda true ) ) ) :-		getIntList ( out lst ( fromLambda false ) )+parseApply :: Parse String Lambda+parseApply = recL1 Apply parseAtom -isFalse :: Rec a -> Bool-isFalse ( In x )	= case x ( Bool True ) of-	In y	-> y ( Bool False ) == Bool False-	_	-> False-isFalse _		= False+parseFun :: Parse String Lambda+parseFun = token "\\" >*> parseParams >*> token "->" >*> parseLambda+	`build` ( \( "\\", ( ps, ( "->", e ) ) ) -> makeFun ps e ) -someList :: Rec a-someList = mkski $ apply ( apply ( lambdaToSKI cons ) two' ) ( lambdaToSKI false )+parseAtom :: Parse String Lambda+parseAtom = ( spot ( isLower . head ) `build` Var ) `alt` parseParens -makeIntList :: [ Int ] -> String-makeIntList [ ]		= lambdaToSKI false-makeIntList ( i : is )	=-	apply ( apply ( lambdaToSKI cons ) $ makeChurch i ) $ makeIntList is+parseParens :: Parse String Lambda+parseParens = token "(" >*> parseLambda >*> token ")" `build` fst . snd -makeChurch :: Int -> String-makeChurch 0 = "`ki"-makeChurch i = apply succ' $ makeChurch ( i - 1 )+parseParams :: Parse String [ String ]+parseParams = list1 $ spot $ isLower . head -succ' = "`s``s`ks``s`kki"+lexer :: String -> [ String ]+lexer ""			= [ ]+lexer ( ' ' : rest )		= lexer rest+lexer ( '\n' : rest )		= lexer rest+lexer ( '\\' : rest )		= "\\" : lexer rest+lexer ( '-' : '>' : rest )	= "->" : lexer rest+lexer ( '(' : rest )		= "(" : lexer rest+lexer ( ')' : rest )		= ")" : lexer rest+lexer ca@( c : _ )+	| isLower c		= let ( ret, rest ) = span isAlphaNum ca in+					ret : lexer rest+lexer ca			= error $ "lexer error: " ++ ca
src/Parse.hs view
@@ -1,31 +1,35 @@ module Parse ( 	Parse, 	none,+	succeed, 	spot,+	token,+	tokens,+	eof, 	(>*>), 	alt, 	build,-	token,-	tokens,-	recL1,-	eof+	list1,+	recL1 ) where -infixr 8 >*>-infix 7 `build`+import Control.Arrow ( first, ( &&& ) ) +infixr	8 >*>+infix	7 `build`+infixl	6 `alt`+ type Parse a b = [ a ] -> [ ( b, [ a ] ) ]  none :: Parse a b-none _ = [ ]+none = const [ ]  succeed :: b -> Parse a b-succeed val inp = [ ( val, inp ) ]+succeed = curry ( : [] )  spot :: ( a -> Bool ) -> Parse a a-spot p ( x : xs )-	| p x		= [ ( x, xs ) ]-spot _ _		= [ ]+spot p ( x : xs )	| p x	= [ ( x, xs ) ]+spot _ _			= [ ]  token :: Eq a => a -> Parse a a token = spot . ( == )@@ -34,24 +38,25 @@ tokens [ ]		= succeed [ ] tokens ( x : xs )	= token x >*> tokens xs `build` uncurry (:) -alt :: Parse a b -> Parse a b -> Parse a b-( p1 `alt` p2 ) inp = p1 inp ++ p2 inp+eof :: Parse a ()+eof [ ]	= [ ( (), [ ] ) ]+eof _	= [ ]  (>*>) :: Parse a b -> Parse a c -> Parse a ( b, c )-( p1 >*> p2 ) inp =-	[ ( ( y, z ), rem2 ) | ( y, rem1 ) <- p1 inp, ( z, rem2 ) <- p2 rem1 ]+( p >*> q ) inp = [ ( ( x, y ), r' ) | ( x, r ) <- p inp, ( y, r' ) <- q r ] +alt :: Parse a b -> Parse a b -> Parse a b+p1 `alt` p2 = uncurry ( ++ ) . ( p1 &&& p2 )+ build :: Parse a b -> ( b -> c ) -> Parse a c-build p f inp = [ ( f x, rem ) | ( x, rem ) <- p inp ]+build p f = map ( first f ) . p +list1 :: Parse a b -> Parse a [ b ]+list1 p = p `build` ( : [] ) `alt` p >*> list1 p `build` uncurry ( : )+ recL1 :: ( b -> b -> b ) -> Parse a b -> Parse a b recL1 f p = ( p >*> recL1' f p ) `build` ( \( x, xs ) -> xs x )  recL1' :: ( b -> c -> b ) -> Parse a c -> Parse a ( b -> b ) recL1' f p = succeed id `alt`-	( ( p >*> recL1' f p ) `build` ( \( x, xs ) ->-		\y -> xs ( f y x ) ) )--eof :: Parse a ()-eof [ ]	= [ ( (), [ ] ) ]-eof _	= [ ]+	( p >*> recL1' f p `build` ( \( x, xs ) y -> xs ( f y x ) ) )
− src/ReadLambda.hs 
@@ -1,108 +0,0 @@-module ReadLambda where--import Parse-import Data.Char---- data SKI = S | K | I deriving Show--data Lambda = Var String | Apply Lambda Lambda | Fun String Lambda-	| S | K | I-	deriving Show--churchTwo :: Lambda-churchTwo =-	Fun "f" $ Fun "x" $ Apply ( Var "f" ) $ Apply ( Var "f" ) ( Var "x" )--lambdaToSKI :: Lambda -> Lambda-lambdaToSKI ( Fun x e ) = out x e-lambdaToSKI ( Apply f a ) = Apply ( lambdaToSKI f ) ( lambdaToSKI a )-lambdaToSKI nf = error $ "lambdaToSKI error: " ++ show nf--onlySKI :: Lambda -> Bool-onlySKI ( Fun _ _ )	= False-onlySKI ( Var _ )	= False-onlySKI ( Apply f a )	= onlySKI f && onlySKI a-onlySKI S		= True-onlySKI K		= True-onlySKI I		= True--notHave :: String -> Lambda -> Bool-notHave x0 ( Var x1 )-	| x0 == x1		= False-	| otherwise		= True-notHave x0 ( Fun _ e )		= notHave x0 e-notHave x0 ( Apply f a )	= notHave x0 f && notHave x0 a-notHave _ _			= True--out :: String -> Lambda -> Lambda-out x0 e-	| onlySKI e	= Apply K $ e-out x0 ( Var x1 )-	| x1 == x0	= I-	| otherwise	= Apply K $ Var x1-{--out x0 ( Apply f ( Var x1 ) )-	| x1 == x0 && notHave x0 f	= f--}-out x0 ( Apply f a )	= Apply ( Apply S  $ out x0 f ) $ out x0 a-out x0 ( Fun x1 e )-	| x0 == x1	= Apply K $ out x0 e-	| otherwise	= ( out x0 ) $ out x1 e-out x0 S		= Apply K S-out x0 K		= Apply K K-out x0 I		= Apply K I--- out x0 ski		= Apply K $ ski--showApply :: Lambda -> String-showApply S = "s"-showApply K = "k"-showApply I = "i"-showApply ( Apply f a ) = "`" ++ showApply f ++ showApply a-showApply other = show other--showSKI = showApply . lambdaToSKI--readLambda :: String -> Lambda-readLambda = fst . fst . head . ( parseLambda >*> eof ) . lexer--parseLambda :: Parse String Lambda-parseLambda = parseApply `alt` parseFun--parseAtom :: Parse String Lambda-parseAtom = ( spot ( isLower . head ) `build` Var ) `alt`-	parseParens--parseParens :: Parse String Lambda-parseParens = ( token "(" >*> parseLambda >*> token ")" ) `build`-	( \( "(", ( body, ")" ) ) -> body )--parseApply :: Parse String Lambda-parseApply = recL1 Apply parseAtom--parseFun :: Parse String Lambda-parseFun =-	( token "\\" >*> parsePars >*> token "->" >*> parseLambda )-		`build` ( \( "\\", ( vs, ( "->", e ) ) ) -> makeFun vs e )--makeFun :: [ String ] -> Lambda -> Lambda-makeFun [ p ] ex	= Fun p ex-makeFun ( p : ps ) ex	= Fun p $ makeFun ps ex--parsePars :: Parse String [ String ]-parsePars = ( spot ( isLower . head ) `build` (:[]) ) `alt`-	( ( spot ( isLower . head ) >*> parsePars ) `build`-		( \( x, xs ) -> x : xs ) )--lexer :: String -> [ String ]-lexer "\n"			= [ ]-lexer ""			= [ ]-lexer ( '\\' : rest )		= "\\" : lexer rest-lexer ( '-' : '>' : rest )	= "->" : lexer rest-lexer ( ' ' : rest )		= lexer rest-lexer ( '\n' : rest )		= lexer rest-lexer ( '(' : rest )		= "(" : lexer rest-lexer ( ')' : rest )		= ")" : lexer rest-lexer ca@( c : _ )-	| isLower c		= let ( ret, rest ) = span isAlphaNum ca in-					ret : lexer rest-lexer ca			= error $ "lexer error: " ++ ca
src/SKI.hs view
@@ -19,45 +19,53 @@ 	show _			= "function"  suc :: Rec a-suc = In sc+suc = In scc 	where-	sc ( Int i )	= Int $ succ i-	sc ( Char c )	= Char $ succ c-	sc _		= error "not int"+	scc ( Int i )	= Int $ succ i+	scc ( Char c )	= Char $ succ c+	scc _		= error "not int" +out_ :: Rec a -> Rec a -> Rec a out_ x = case x of 	In f	-> f-	_	-> \y -> Error "not function"+	_	-> \_ -> Error "not function"  oi :: Rec a -> Rec a oi x = x-i = In oi+ii :: Rec a+ii = In oi  ok :: Rec a -> Rec a ok x = In $ \_ -> x+k :: Rec a k = In ok  os :: Rec a -> Rec a -- s x y z = x z ( y z ) os x = In $ \y -> In $ \z -> ( out_ $ out_ x z ) ( out_ y z )+s :: Rec a s = In os  readChurch :: Rec a -> Rec a-readChurch cn = cn `out_` suc `out_` ( Int 0 )+readChurch cn = cn `out_` suc `out_` Int 0 +mkski :: String -> Rec a mkski = fst . makeSKI  makeSKI :: String -> ( Rec a, String )-makeSKI ( '`' : rest ) = let-	( c, rest' ) = makeSKI rest-	( c', rest'' ) = makeSKI rest' in case c of+makeSKI ( '`' : rest )	= let+	( c, rest' )	= makeSKI rest+	( c', rest'' )	= makeSKI rest' in case c of 		In f	-> ( f c', rest'' ) 		_	-> ( Error "in makeSKI", rest'' ) --	( out c c', rest'' )-makeSKI ( 's' : rest ) = ( s, rest )-makeSKI ( 'k' : rest ) = ( k, rest )-makeSKI ( 'i' : rest ) = ( i, rest )+makeSKI ( 's' : rest )	= ( s, rest )+makeSKI ( 'k' : rest )	= ( k, rest )+makeSKI ( 'i' : rest )	= ( ii, rest )+makeSKI _		= error "makeSKI error" +sc :: Rec a sc = mkski "`s``s`ks``s`kki" -mul x y = out ( out x ( out y sc ) ) ( out k i )+mul :: Rec a -> Rec a -> Rec a+mul x y = out ( out x ( out y sc ) ) ( out k ii )
src/SkiToLambda.hs view
@@ -1,112 +1,87 @@ module SkiToLambda ( main ) where -import System.Environment--data Lambda = Var String | Apply Lambda Lambda | Fun String Lambda-	deriving Show--main :: [ String ] -> IO ()-main args = do---	( n : rest ) <- getArgs-	let ( n : rest ) = args-	case rest of-		[ ]	-> interact $ ( ++ "\n" ) . showLambda . applyApp . applyI .-			times ( read n ) apply . one . readSKI 0-		[ "-h" ]	-> interact $ unlines . devide 80 . showLambdaTop . applyApp . applyI .-			times ( read n ) apply . one . readSKI 0-	where-	one ( x, _, _ ) = x--times :: Int -> ( a -> a ) -> a -> a-times 0 _ x = x-times n f x = times ( n - 1 ) f $ f x--devide :: Int -> [ a ] -> [ [ a ] ]-devide n [ ]	= [ ]-devide n xs	= take n xs : devide n ( drop n xs )--skiToLambda :: String -> String-skiToLambda = fst . parens--readSKI :: Int -> String -> ( Lambda, String, Int )-readSKI n ( '`' : rest ) = let-	( f, rest2, n2 ) = readSKI n rest-	( a, rest3, n3 ) = readSKI n2 rest2 in-	( Apply f a, rest3, n3 )-readSKI n ( 'i' : rest ) = ( Fun x $ Var x, rest, n + 1 )-	where	x = "x" ++ show n-readSKI n ( 'k' : rest ) = ( Fun x $ Fun y $ Var x, rest, n + 1 )-	where	x = "x" ++ show n-		y = "y" ++ show n-readSKI n ( 's' : rest ) = ( Fun x $ Fun y $ Fun z $-	Apply ( Apply ( Var x ) ( Var z ) ) ( Apply ( Var y ) ( Var z ) ), rest, n +1 )-	where	x = "x" ++ show n-		y = "y" ++ show n-		z = "z" ++ show n--showLambda, showLambdaH, showLambdaApply, showLambdaFun :: Lambda -> String-showLambda ( Var v ) = v-showLambda ( Apply f a ) = "(" ++ showLambda f ++ " " ++ showLambda a ++ ")"-showLambda ( Fun p e ) = "(\\" ++ p ++ " -> " ++ showLambda e ++ ")"--showLambdaTop ( Apply f a )	= showLambdaApply f ++ " " ++ showLambdaH a-showLambdaTop ( Fun p e )	= "\\" ++ p ++ showLambdaFun e-showLambdaTop v			= showLambdaH v+import Data.List ( minimumBy )+import Data.Ord ( comparing )+import Control.Arrow ( ( &&& ) ) -showLambdaH ( Var v ) = v-showLambdaH ( Apply f a ) = "(" ++ showLambdaApply f ++ " " ++ showLambdaH a ++ ")"-showLambdaH ( Fun p ( Var v ) )-	| p == v	= "I"-showLambdaH ( Fun p1 ( Fun p2 ( Var v ) ) )-	| p1 == v	= "K"-	| p2 == v	= "KI"---	| otherwise	= "hoge"-showLambdaH ( Fun p e ) = "(\\" ++ p ++ showLambdaFun e ++ ")"+infixl 9 :$:+infixr 8 :->+data Lambda = Var String | Lambda :$: Lambda | String :-> Lambda | K | I -showLambdaApply ( Apply f a )	= showLambdaApply f ++ " " ++ showLambdaH a--- showLambdaApply ( Fun p e )	= "\\" ++ p ++ showLambdaFun e-showLambdaApply e		= showLambdaH e+instance Show Lambda where+	show ( Var v )		= v+	show ap@( _ :$: _ )	= showAp ap+		where+		showAp ( f :$: a )	= showAp f ++ " " ++ par show a+		showAp e		= par show e+		par sh a@( _ :$: _ )	= "(" ++ sh a ++ ")" +		par sh f@( _ :-> _ )	= "(" ++ sh f ++ ")"+		par sh e		= sh e+	show f@( _ :-> _ )		= '\\' : showFun f+		where+		showFun ( p :-> e )	= p ++ " " ++ showFun e+		showFun e		= "-> " ++ show e+	show K			= "K"+	show I			= "I" -showLambdaFun ( Fun p e )	= " " ++ p ++ showLambdaFun e-showLambdaFun e			= " -> " ++ showLambdaApply e+size :: Lambda -> Int+size ( f :$: a )	= size f + size a+size ( _ :-> e )	= 1 + size e+size _			= 1 -parens :: String -> ( String, String )-parens ( '`' : rest ) =	let-	( f, rest2 ) = parens rest-	( a, rest3 ) = parens rest2 in-	( "(" ++ f ++ " " ++ a ++ ")", rest3 )-parens ( c : rest ) = ( [ c ], rest )+main :: [ String ] -> IO ()+main args = interact $ case args of+	[ ]		-> ( ++ "\n" ) . show . skiToLambda+	[ "-h" ]	-> unlines . devide 80 . show . ki . skiToLambda+	_		-> error "bad arguments"+	where+	devide _ [ ]	= [ ]+	devide n xs	= take n xs : devide n ( drop n xs )+	ki ( p :-> Var v )		| p == v	= I+	ki ( p1 :-> p2 :-> Var v )	| p1 == v	= K+					| p2 == v	= K :$: I+	ki ( f :$: a )					= ki f :$: ki a+	ki ( p :-> e )					= p :-> ki e+	ki kiv						= kiv -applyI :: Lambda -> Lambda-applyI ( Apply ( Fun p ( Var v ) ) ar )-	| p == v	= ar-	| otherwise	= Var v-applyI ( Apply ( Fun p1 ( Fun p2 ( Var v ) ) ) a )-	| p2 == v	= Fun p2 ( Var v )-	| p1 == v	= Fun p2 a-applyI ( Apply f a )	= Apply ( applyI f ) $ applyI a-applyI ( Fun p e )	= Fun p $ applyI e-applyI ( Var v )	= Var v+skiToLambda :: String -> Lambda+skiToLambda = betaKI .+	minimumBy ( comparing size ) . take 15 . iterate beta . fst . readSki 0 -applyApp :: Lambda -> Lambda-applyApp ( Apply ( Fun p ( Apply ( Var v ) a ) ) f )-	| p == v	= Apply f a-applyApp ( Apply f a )	= Apply ( applyApp f ) $ applyApp a-applyApp ( Fun p e )	= Fun p $ applyApp e-applyApp ( Var v )	= Var v+readSki :: Int -> String -> ( Lambda, ( Int, String ) )+readSki n ( '`' : cs )	= let	( f, ncs )	= readSki n cs+				( a, ncs' )	= uncurry readSki ncs in+				( f :$: a, ncs' )+readSki n ( c : cs )	= ( case c of+	'i'	-> fx x+	'k'	-> fx $ fy x+	's'	-> fx $ fy $ fz $ x :$: z :$: ( y :$: z )+	_	-> error "readSki error", ( n + 1, cs ) ) +	where+	[ ( fx, x ), ( fy, y ), ( fz, z ) ] =+		( ( ( :-> ) &&& Var ) . ( : show n ) ) `map` "xyz"+readSki _ _		= error "readSki error" -apply :: Lambda -> Lambda-apply ( Apply fr ar ) =	case apply fr of-	Fun p e -> applyPara p ( apply ar ) e-	nf	-> Apply nf ( apply ar )-apply ( Fun p e ) = Fun p ( apply e )-apply ( Var v ) = Var v+beta, betaKI :: Lambda -> Lambda+beta ( fun :$: arg )	= case beta fun of+	p :-> e	-> para p ( beta arg ) e+	ex	-> ex :$: beta arg+	where+	para p a v@( Var x )	| p == x	= a+				| otherwise	= v+	para p a ( f :$: b )			= para p a f :$: para p a b+	para p a f@( q :-> e )	| p == q	= f+				| otherwise	= q :-> para p a e+	para _ _ ki				= ki+beta ( p :-> e )	= p :-> beta e+beta kiv		= kiv -applyPara :: String -> Lambda -> Lambda -> Lambda-applyPara p a1 ( Var v )-	| p == v		= a1-	| otherwise		= Var v-applyPara p a1 ( Apply f a2 )	= Apply ( applyPara p a1 f ) ( applyPara p a1 a2 )-applyPara p1 a1 ( Fun p2 e )-	| p1 == p2		= Fun p2 e-	| otherwise		= Fun p2 $ applyPara p1 a1 e+betaKI ( ( p :-> v@( Var x ) ) :$: ar )+	| p == x	= ar+	| otherwise	= v+betaKI ( ( p :-> f@( q :-> Var x ) ) :$: a )+	| q == x	= f+	| p == x	= "_" :-> a+betaKI ( f :$: a )	= betaKI f :$: betaKI a+betaKI ( p :-> e )	= p :-> betaKI e+betaKI kiv		= kiv
src/SkiToZot.hs view
@@ -1,11 +1,13 @@ module SkiToZot ( main ) where +main :: IO () main = interact skiToZot  skiToZot :: String -> String-skiToZot "\n"		= ""-skiToZot ""		= ""-skiToZot ( '`' : rest )	= '1' : skiToZot rest-skiToZot ( 'i' : rest ) = "100" ++ skiToZot rest-skiToZot ( 'k' : rest ) = "1010100" ++ skiToZot rest-skiToZot ( 's' : rest ) = "101010100" ++ skiToZot rest+skiToZot ""			= ""+skiToZot ( '\n' : rest )	= skiToZot rest+skiToZot ( '`' : rest )		= '1' : skiToZot rest+skiToZot ( 'i' : rest ) 	= "100" ++ skiToZot rest+skiToZot ( 'k' : rest ) 	= "1010100" ++ skiToZot rest+skiToZot ( 's' : rest ) 	= "101010100" ++ skiToZot rest+skiToZot _			= error "skiToZot error"
src/Zot.hs view
@@ -1,170 +1,83 @@-{-# LANGUAGE PackageImports #-}- module Zot ( main, mainFile ) where -import "monads-tf" Control.Monad.State-import Data.Char+import Control.Monad ( foldM ) -data Fun = Fun { apply_ :: Fun -> IO Fun } | Int Int+data Fun = Fun ( Fun -> IO Fun ) | Zero | One -apply :: Fun -> Fun -> IO Fun-apply ( Fun f )		= f-apply ( Int int )	= apply i+mkFun :: ( Fun -> Fun ) -> Fun+mkFun f =  Fun $ return . f  instance Show Fun where-	show ( Int i )	= show i-	show Fun{ }	= "function"+	show Zero	= "0"+	show One	= "1"+	show ( Fun _ )	= "function"+	showList fs	= ( concatMap show fs ++ ) -k, i :: Fun-s = Fun $ \x -> return $ Fun $ \y -> return $ Fun $ \z -> do-	xz <- apply x z-	yz <- apply y z-	apply xz yz-k = Fun $ \x -> return $ Fun $ \y -> return x-i = Fun return+instance Read Fun where+	readsPrec _ ( '0' : rest )	= [ ( Zero, rest ) ]+	readsPrec _ ( '1' : rest )	= [ ( One, rest ) ]+	readsPrec _ _			= error "read Fun failed"+	readList str			= [ readl str ]+		where+		readl ""		= ( [ ], "" )+		readl ( '0' : cs )	= let ( r, rest ) = readl cs in+						( Zero : r, rest )+		readl ( '1' : cs )	= let ( r, rest ) = readl cs in+						( One : r, rest )+		readl _			= error "read [ Fun ] failed" -empty, zero, one :: Fun-empty = Fun $ \c -> apply c i-zero = Fun $ \c -> apply c $ Fun $ \f -> do-	fs <- apply f s-	apply fs k-one = Fun $ \c -> return $ Fun $ \ll -> apply ll $-	Fun $ \l -> return $ Fun $ \rr -> apply rr $ Fun $ \r -> do-		lr <- apply l r-		apply c lr+( $$ ) :: Fun -> Fun -> IO Fun+( $$ ) ( Fun f )	= f+( $$ ) Zero		= ( zero $$ )+( $$ ) One		= ( one $$ ) -remCom :: String -> String-remCom = unlines . map ( takeWhile ( /= '#' ) ) . lines+infixl 6 >$$+( >$$ ) :: IO Fun -> Fun -> IO Fun+f >$$ a = f >>= ( $$ a ) -main :: IO ()-main = do-	fun <- getContents >>= makeZot . filter ( not . isSpace ) . remCom-	funOut <- apply fun =<< output-	apply funOut pr---	apply fun pr-	putStrLn ""+infixr 8 $$<+( $$< ) :: Fun -> IO Fun -> IO Fun+f $$< a = ( f $$ ) =<< a -mainFile :: String -> IO ()-mainFile fn = do-	prg <- readFile fn-	arg <- getContents-	fun <- makeZot $ filter ( not . isSpace ) $ remCom $ prg ++ arg-	funOut <- apply fun =<< output-	apply funOut pr-	putStrLn ""+infixl 7 >$$<+( >$$< ) :: IO Fun -> IO Fun -> IO Fun+f >$$< a = f >>= ( $$< a ) -main_ :: IO ()-main_ = do-	apply i ( Int 3 ) >>= print-	ii <- makeZot "100"-	apply ii ( Int 3 ) >>= print-	kkii <- makeZot "10100"-	kkii4 <- apply kkii ( Int 4 )-	print kkii4-	apply kkii4 ( Int 7 ) >>= print-	k8 <- apply k ( Int 8 )-	apply k8 ( Int 3 ) >>= print-	ki <- apply k i-	ki3 <- apply ki ( Int 3 )-	apply ki3 ( Int 5 ) >>= print-	intOne <- interrogate =<< output-	intOne0 <- apply intOne ( Int 0 )-	intOne01 <- apply intOne0 ( Int 1 )-	apply intOne01 ( Int 2 ) >>= print-	pr1011-	putStrLn ""-	apply lst10 pr-	putStrLn ""-	rv <- makeZot $ rev ++ "1101000"-	rvo <- apply rv =<< output-	apply rvo pr-	putStrLn ""-	lst10f <- lst10''-	apply lst10f pr-	putStrLn ""-	lst10f <- lst10'---	lst10fo <- apply lst10f =<< output-	apply lst10f pr-	putStrLn ""-	kif <- ioki-	kif3 <- apply kif ( Int 3 )-	apply kif3 ( Int 5 ) >>= print+cont :: Fun -> Fun+cont = Fun . flip ( $$ ) -($$) :: Fun -> Fun -> IO Fun-f $$ a = apply f a+s, k, i :: Fun+s = mkFun $ \x -> mkFun $ \y -> Fun $ \z -> x $$ z >$$< y $$ z+k = mkFun $ mkFun . const+i = mkFun id -makeZot :: String -> IO Fun-makeZot "" = return $ empty-makeZot bs = do-	f <- makeZot $ init bs-	apply f $ case last bs of-		'1' -> one-		'0' -> zero+empty, zero, one :: Fun+empty	= cont i+zero	= cont $ Fun $ \f -> f $$ s >$$ k+one	= mkFun $ \c -> cont $ mkFun $ \l -> cont $ Fun $ \r -> c $$< l $$ r  pr :: Fun-pr = Fun $ \x -> do-	ix <- interrogate x-	ix0 <- apply ix ( Int 0 )-	apply ix0 ( Int 1 ) >>= putStr . show-	return pr--pr1011 :: IO Fun-pr1011 = do-	pr2 <- apply pr one-	pr3 <- apply pr2 zero-	pr4 <- apply pr3 one-	apply pr4 one--lst10 :: Fun-lst10 = Fun $ \f -> do---	( \g -> g zero )-	f1 <- apply f one-	apply f1 zero--ioki :: IO Fun-ioki = makeZot "110100100"--iok1 :: IO Fun-iok1 = makeZot "1101001"+pr = Fun $ \x -> interrogate x >$$ Zero >$$ One >>= putStr . show >> return pr -lst10' :: IO Fun-lst10' = makeZot $ skiToZot "``s``si`k0`k1"--- lst10' = makeZot $ skiToZot "``si`k1"--- lst10' = makeZot "1 1 101010100 1 1 101010100 100 1 1010100 1 1 1010100 0"--- lst10' = makeZot "11101010100100110101001"+interrogate :: Fun -> IO Fun+interrogate f = f $$ i >$$ i >$$ i >$$ k -skiToZot :: String -> String-skiToZot ""		= ""-skiToZot ( '`' : rest )	= '1' : skiToZot rest-skiToZot ( 's' : rest ) = "101010100" ++ skiToZot rest-skiToZot ( 'k' : rest ) = "1010100" ++ skiToZot rest-skiToZot ( 'i' : rest ) = "100" ++ skiToZot rest-skiToZot ( '1' : rest ) = "1" ++ skiToZot rest-skiToZot ( '0' : rest ) = "0" ++ skiToZot rest+output :: IO Fun+output = k $$< k $$< k $$< k $$< k $$< k $$ i -lst10'' :: IO Fun-lst10'' = do-	si <- apply s i-	k1 <- apply k one-	k0 <- apply k zero-	sik1 <- apply si k1-	ssik1 <- apply s sik1-	apply ssik1 k0+readZot :: String -> IO Fun+readZot = foldM ( $$ ) empty . read . filter ( `elem` "01" ) -interrogate :: Fun -> IO Fun-interrogate f = do-	fi <- apply f i-	fii <- apply fi i-	fiii <- apply fii i-	apply fiii k+interpret :: String -> IO ()+interpret src = readZot ( removeComment src ) >$$< output >$$ pr >> putStrLn ""+	where+	removeComment = concatMap ( takeWhile ( /= '#' ) ) . lines -output :: IO Fun-output = do-	ki <- apply k i-	kki <- apply k ki-	kkki <- apply k kki-	kkkki <- apply k kkki-	kkkkki <- apply k kkkki-	apply k kkkkki+main :: IO ()+main = getContents >>= interpret -rev = "1111010101001110101010010011010100100100111010101001110101010011010100101010100111010101001101010011010101001101010010101010011101010100111010101001101010010101010011101010100110101001101010100110101001010101001110101010011010100110101010011010100110101010011101010100111010101001110101010011101010100100110101001001101010010011010100100110101001010100111010101001101010011010101001101010011010101001101010010101001110101010011101010100110101001010101001110101010011010100110101010011010100101010100111010101001101010011010101001110101010011010100101010100101010011101010100110101001010100111010101001110101010011010100101010100111010101001101010010101001110101010011010100101010100101010011010100111010101001101010011010101001001010100110101001010100111010101001101010011010101001101010011010101001101010010101001110101010011101010100110101001010101001110101010011010100110101010011010100101010100111010101001101010011010101001110101010011010100101010100101010011101010100110101001010100111010101001110101010011010100101010100111010101001101010010101001110101010011010100101010100101010011010100111010101001101010011010101001001010100110101001010100111010101001101010010101001010100"+mainFile :: String -> IO ()+mainFile fn = do+	prg <- readFile fn+	arg <- getContents+	interpret $ prg ++ arg
src/ZotToSki.hs view
@@ -1,41 +1,21 @@ module ZotToSki ( main ) where -import Parse--rev = "1111010101001110101010010011010100100100111010101001110101010011010100101010100111010101001101010011010101001101010010101010011101010100111010101001101010010101010011101010100110101001101010100110101001010101001110101010011010100110101010011010100110101010011101010100111010101001110101010011101010100100110101001001101010010011010100100110101001010100111010101001101010011010101001101010011010101001101010010101001110101010011101010100110101001010101001110101010011010100110101010011010100101010100111010101001101010011010101001110101010011010100101010100101010011101010100110101001010100111010101001110101010011010100101010100111010101001101010010101001110101010011010100101010100101010011010100111010101001101010011010101001001010100110101001010100111010101001101010011010101001101010011010101001101010010101001110101010011101010100110101001010101001110101010011010100110101010011010100101010100111010101001101010011010101001110101010011010100101010100101010011101010100110101001010100111010101001110101010011010100101010100111010101001101010010101001110101010011010100101010100101010011010100111010101001101010011010101001001010100110101001010100111010101001101010010101001010100"--test = "11010101001010100"+import Parse ( Parse, token, tokens, ( >*> ), alt, build, eof ) --- main = putStrLn $ zotToSKI $ ( replicate 1 '1' ++ ) $ concat $ replicate 2 rev+main :: IO () main = interact $ zotToSKI . concat . lines -shortest :: [ [ a ] ] -> [ a ]-shortest [ ] = [ ]-shortest [ l ] = l-shortest ( l : ls )-	| length l < length ( shortest ls )	= l-	| otherwise				= shortest ls- zotToSKI :: String -> String-zotToSKI = head . {- shortest {- head -} . -} map fst . ( parseZot >*> eof `build` fst )+zotToSKI = fst . head . ( parseZot >*> eof `build` fst )  parseZot :: Parse Char String-parseZot = parseApply `alt` parseSKI -- `alt` parse10+parseZot = parseApply `alt` parseS `alt` parseK `alt` parseI  parseApply :: Parse Char String parseApply = token '1' >*> parseZot >*> parseZot `build` 	\( _, ( ski1, ski2 ) ) -> '`' : ski1 ++ ski2 -parseSKI, parse10 :: Parse Char String-parseSKI = parseI `alt` parseK `alt` parseS-parse10 = parse1 `alt` parse0-	-parseI, parseK, parseS :: Parse Char String-parseI = tokens "100" `build` const "i"-parseKI = tokens "10100" `build` const "ki"-parseK = tokens "1010100" `build` const "k"+parseS, parseK, parseI :: Parse Char String parseS = tokens "101010100" `build` const "s"--parse1, parse0 :: Parse Char String-parse1 = token '1' `build` const "1"-parse0 = token '0' `build` const "0"+parseK = tokens "1010100" `build` const "k"+parseI = tokens "100" `build` const "i"
src/zot.hs view
@@ -1,23 +1,25 @@ module Main where -import qualified Zot-import qualified LambdaToSki-import qualified SkiToLambda-import qualified SkiToZot-import qualified ZotToSki-import qualified AddEcho+import qualified Zot		( main, mainFile )+import qualified SkiToZot	( main )+import qualified ZotToSki	( main )+import qualified LambdaToSki	( main )+import qualified SkiToLambda	( main )  import System.Environment ( getArgs ) import Data.List ( isSuffixOf )  main :: IO () main = do-	cmd : args <- getArgs-	case cmd of-		"-"					-> Zot.main-		"lambdaToSki"				-> LambdaToSki.main-		"skiToLambda"				-> SkiToLambda.main args-		"skiToZot"				-> SkiToZot.main-		"zotToSki"				-> ZotToSki.main-		"arg"					-> AddEcho.main args-		_	| ".zot" `isSuffixOf` cmd	-> Zot.mainFile cmd+	ca@( ~( cmd : args ) ) <- getArgs+	let command = if null ca then "" else cmd+	case command of+		"skiToZot"	-> SkiToZot.main+		"zotToSki"	-> ZotToSki.main+		"lambdaToSki"	-> LambdaToSki.main+		"skiToLambda"	-> SkiToLambda.main args+		"arg"		-> interact (++ concat args )+		"-"		-> Zot.main+		_+			| ".zot" `isSuffixOf` command	-> Zot.mainFile command+			| otherwise			-> error "bad arguments"
zot.cabal view
@@ -2,7 +2,7 @@ cabal-version:	>= 1.6  name:		zot-version:	0.0.1+version:	0.0.2 stability:	experimental author:		Yoshikuni Jujo <PAF01143@nifty.ne.jp> maintainer:	Yoshikuni Jujo <PAF01143@nifty.ne.jp>@@ -13,7 +13,7 @@ category:	Language synopsis:	Zot language description:-  Zot language+  Zot language ( http://semarch.linguistics.fas.nyu.edu/barker/Iota/zot.html )   .   > echo "10100" | cat examples/reverse.zot - | zot -   > 00101@@ -23,13 +23,13 @@   .   And try   .-  > cat examples/reverse.zot | zot zotToSki | zot skiToLambda 3+  > cat examples/reverse.zot | zot zotToSki | zot skiToLambda   .   and   .-  > cat examples/reverse.zot | zot zotToSki | zot skiToLambda 3 -h+  > cat examples/reverse.zot | zot zotToSki | zot skiToLambda -h -data-files:	examples/reverse.lambda, examples/reverse.zot+data-files:	examples/reverse.lambda, examples/reverse.zot, README  source-repository	head   type:		git@@ -38,5 +38,6 @@ executable	zot   hs-source-dirs:	src   main-is:		zot.hs-  other-modules:	Zot, LambdaToSki, SkiToLambda, SkiToZot, ZotToSki, AddEcho, Parse, ReadLambda, SKI+  other-modules:	Zot, LambdaToSki, SkiToLambda, SkiToZot, ZotToSki, Parse, SKI   build-depends:	base > 3 && < 5, monads-tf+  ghc-options:		-Wall