-- Functional Programming, Assignment #4
-- By Adam Poswolsky

-- Problem 1 Game Show
-- FINAL Submission

type Rule = [Char]
play :: [Rule] -> String -> Bool

--initK refers to the initial continuation used
initK :: String -> [Rule] -> Bool
initK = (\s' -> \r' -> if (s' == [] && r' == []) then True else False)

play rules s = acc s [] (makeReg rules) initK

--makeReg takes a list of Rules and converts it to the appropriate expression
--to be used in the "acc" routine.
makeReg rules = Star(makeReg' rules)
makeReg' [x] = Chars x
makeReg' (x:xs) = Plus (Chars x) (makeReg' xs)

--For testing purposes, play2 is used
--to use the rules that were on the pset.
myRules = ["vke", "vt"]
play2 = play myRules

--Note that the only change to Regular Expressions is that
--the base case of Char was changed to be a list of chars.
data Reg
	= Zero
	| One
	| Chars [Char]
	| Plus Reg Reg
	| Times Reg Reg
	| Star Reg
	deriving Show

--
--HELPER FUNCTIONS for removeChar
--
--findIndex::Char -> [Rule] -> [Int]
--findIndex:
--   Given:  (1) character 'c' and (2) list of Rules s
--   Result:  returns a lit of indices where we
--            have a rule that starts with 'c'.
findIndex c s = findIndex' c s 1
findIndex' c [] num = []
findIndex' c ((c':x):xs) num = if (c==c') then [num]++(findIndex' c xs (num+1))
				else findIndex' c xs (num+1)

--removeIndex::[Rule] -> Int -> [Rule]
--removeIndex:
--    Given:  (1) list of rules and (2) index
--    Result: Returns the index'ed entry of the list
removeIndex (x:xs) num =
    if (num==1) then
       --We need to remove the first character.
       if (tail(x)==[]) then
	  xs
       else
          tail(x):xs
    else
       x:(removeIndex xs (num-1))

-- UNCOMMENT THIS LINE AND HAT WILL WORK.. OTHERWISE IT WONT
--------------------------------------------------------------
--removeIndexListVersion::[Rule] -> [Int] -> [[Rule]]
--------------------------------------------------------------
--removeIndexListVersion
--    This just takes a 
--         (1) list of rules
--         (2) list of indices 
--   and calls removeIndex on each element of (2) with list in (1). 
removeIndexListVersion s [] = []
removeIndexListVersion s (x:xs) = [(removeIndex s x)]++(removeIndexListVersion s xs)

--
--END OF HELPER FUNCTIONS for removeChar
--

removeChar::Char -> [Rule] -> [[Rule]]
-- removeChar
--  Input:  (1) character c
--          (2) list of rules s
--  Output:  Every rule which we find that starts with 'c', we create a new list of rules
--           which has that 'c' removed.  So the output is a list of a list of rules.
removeChar c s = removeIndexListVersion s (findIndex c s)


-- Note that acc now takes a [Rule] which indicates what is left to be matched.
acc :: String -> [Rule] -> Reg -> (String -> [Rule] -> Bool) -> Bool
acc s r Zero k = False
acc s r One k = k s r
acc s r (Plus r1 r2) k =
	(acc s r r1 k) || (acc s r r2 k)
acc s r (Times r1 r2) k =
	acc s r r1 (\s' -> \r' -> acc s' r' r2 k)
acc s r (Star r1) k =
	(k s r) || (acc s r r1 (\s' -> \r' -> acc s' r' (Star r1) k))

--This is the main work of what to do when we get to one of the rules
--Which happens to be a list of Chars.

--If we are matching the empty string to an empty list of chars
acc [] r (Chars []) k = k [] r

--If we are matching an empty string to a non-empty list of chars, 
--we must return False
acc [] r (Chars _) k = False

--We are matching a non-empty string to an empty list of chars
acc (c:s) r (Chars []) k =
	-- match as much as we can with c:s and also try to just
	-- call the continuation
	(foldl (\a -> \b -> a || acc s b (Chars []) k ) False (removeChar c r)) || k (c:s) r

--We are matching a non-empty string to a non-empty list of chars
acc (c1:c2) r (Chars (c1':c2')) k = 
        -- If c1 == c1'
	-- We can either call the continuation (which signifies that we are using this rule (c1':c2'))
        -- or we can call "acc c2 r (Chars c2') k"
        --
        -- Whether c1 equals c1' or not, we can 
        -- try to match as much of (c1:c2) as we can with r
	if c1 == c1' then
		acc c2 r (Chars c2') k || (foldl (\a -> \b -> a || acc c2 b (Chars (c1':c2')) k ) False (removeChar c1 r)) || k c2 (if c2'==[] then r else c2':r)
	else
	       foldl (\a -> \b -> a || acc c2 b (Chars (c1':c2')) k ) False (removeChar c1 r)


main=putStrLn (if (play ["vt", "vve"] "vvtvttt") then "True" else "False")