Will GHC transform an expression with intermediate values as efficiently as one without?
e.g.
main = print $ f ["aa", "bb", "cc"]
f x =
let a = map (map toUpper) x
b = filter (\z -> 'C' /= head z) a
c = foldl1 (++) b
in c
seems to have very different core output (with -ddump-simple) than with
f x = foldl1 (++) $ filter (\z -> 'C' /= head z) $ map (map toUpper) x
Could an expression with intermediate values take (significantly) longer to evaluate?
Linear use of intermediate let bindings is equivalent to putting (.) between the values.
GHC will fuse through such pipelines. You can see from the results of -ddump-simpl-stats
With let Bindings:
15 RuleFired
1 ++
1 Class op /=
1 Class op show
1 Class op showList
1 filter
1 fold/build
1 foldr/app
1 map
1 neChar#->case
3 unpack
3 unpack-list
Using a pipeline:
15 RuleFired
1 ++
1 Class op /=
1 Class op show
1 Class op showList
1 filter
1 fold/build
1 foldr/app
1 map
1 neChar#->case
3 unpack
3 unpack-list
And the same fused worker:
With let Bindings:
Main.main_go =
\ (ds_aAz :: [[GHC.Types.Char]]) ->
case ds_aAz of _ {
[] -> GHC.Types.[] # [GHC.Types.Char];
: y_aAE ys_aAF ->
case GHC.Base.map
# GHC.Types.Char # GHC.Types.Char GHC.Unicode.toUpper y_aAE
of wild1_azI {
[] ->
GHC.List.badHead
`cast` (UnsafeCo (forall a_azK. a_azK) [[GHC.Types.Char]]
:: (forall a_azK. a_azK) ~ [[GHC.Types.Char]]);
: x_azM ds1_azN ->
case x_azM of _ { GHC.Types.C# c2_aAa ->
case c2_aAa of _ {
__DEFAULT ->
GHC.Types.: # [GHC.Types.Char] wild1_azI (Main.main_go ys_aAF);
'C' -> Main.main_go ys_aAF
}
Pipeline:
Main.main_go =
\ (ds_aAA :: [[GHC.Types.Char]]) ->
case ds_aAA of _ {
[] -> GHC.Types.[] # [GHC.Types.Char];
: y_aAF ys_aAG ->
case GHC.Base.map
# GHC.Types.Char # GHC.Types.Char GHC.Unicode.toUpper y_aAF
of wild1_azB {
[] ->
GHC.List.badHead
`cast` (UnsafeCo (forall a_azD. a_azD) [[GHC.Types.Char]]
:: (forall a_azD. a_azD) ~ [[GHC.Types.Char]]);
: x_azF ds1_azG ->
case x_azF of _ { GHC.Types.C# c2_aA3 ->
case c2_aA3 of _ {
__DEFAULT ->
GHC.Types.: # [GHC.Types.Char] wild1_azB (Main.main_go ys_aAG);
'C' -> Main.main_go ys_aAG
}
}
Did you forget to compile with -O2 ?
Related
I got this code:
type regexp =
| V (* void *)
| E (* epsilon *)
| C of char (* char *)
| U of regexp * regexp (* a + b *)
| P of regexp * regexp (* a.b *)
| S of regexp (* a* *)
;;
...
module ReS = Set.Make (struct
type t = regexp
let compare = compare
end)
(* module/type for pairs of sets of regular expressions *)
module RePS = Set.Make (struct
type t = ReS.t * ReS.t
let compare = compare
end)
(*module/type for set of chars *)
module CS = Set.Make(Char)
let ewps = ReS.exists ewp;;
let atmost_epsilons = ReS.for_all atmost_epsilon;;
let infinitys = ReS.exists infinity;;
let rigth_concat s = function
| V -> ReS.empty
| E -> s
| r -> ReS.map (fun e -> P (e,r)) s
;;
let ( *.* ) = rigth_concat;;
(* partial derivative of a regular expression *)
let rec pd a re = function
| V | E -> ReS.empty
| C b when b=a -> ReS.singleton E
| C b -> ReS.empty
| U (r, s) -> ReS.union (pd a r) (pd a s)
| P (r, s) when ewp a -> ReS.union ((pd a r) *.* s) (pd a s)
| P (r, s) -> (pd a r) *.* s
| S r as re -> (pd a r) *.* re
;;
let rec unions f s =
ReS.fold (fun re acc -> ReS.union (f re) acc ) s ReS.empty
;;
let rec pds a s = unions (pd a) s;;
let rec pdw (sr: ReS.t) = function
| [] -> sr
| a::tl -> pds a (pdw sr tl)
;;
I checked the types of return values and i think they are correct, but it returns the following error and I am not sure why.
This expression has type regexp -> ReS.t but an expression was
expected of type ReS.t
In function "pd" in line that has error
| U (r, s) -> ReS.union (pd a r) (pd a s)
I believe your problem is caused by the fact that function supplies an implicit parameter. This expression:
function None -> 0 | Some x -> x
is a function with one parameter. So in your case you have defined pd to have three parameters. It looks to me like you're expecting it to have two parameters.
You can probably change your function ... to match re with instead. Or you can remove the explicit re parameter, and use the parameter that's implicit in function.
I was working on a HackerRank problem today and initially wrote it with indexing and it was incredibly slow for most of the test cases because they were huge. I then decided to switch it to head:tail pattern matching and it just zoomed. The difference was absolutely night and day, but I can't figure out how it was such a change in efficiency. Here is the code for reference if it is at all useful
Most efficient attempt with indexing
count :: Eq a => Integral b => a -> [a] -> b
count e [] = 0
count e (a:xs) = (count e xs +) $ if a == e then 1 else 0
fullCheck :: String -> Bool
fullCheck a = prefixCheck 0 (0,0,0,0) a (length a) && (count 'R' a == count 'G' a) && (count 'Y' a == count 'B' a)
prefixCheck :: Int -> (Int, Int, Int, Int) -> String -> Int -> Bool
prefixCheck n (r',g',y',b') s l
| n == l = True
| otherwise =
((<= 1) $ abs $ r - g) && ((<= 1) $ abs $ y - b)
&& prefixCheck (n+1) (r,g,y,b) s l
where c = s !! n
r = if c == 'R' then r' + 1 else r'
g = if c == 'G' then g' + 1 else g'
y = if c == 'Y' then y' + 1 else y'
b = if c == 'B' then b' + 1 else b'
run :: Int -> IO ()
run 0 = putStr ""
run n = do
a <- getLine
print $ fullCheck a
run $ n - 1
main :: IO ()
main = do
b <- getLine
run $ read b
head:tail pattern matching attempt
count :: Eq a => Integral b => a -> [a] -> b
count e [] = 0
count e (a:xs) = (count e xs +) $ if a == e then 1 else 0
fullCheck :: String -> Bool
fullCheck a = prefixCheck (0,0,0,0) a && (count 'R' a == count 'G' a) && (count 'Y' a == count 'B' a)
prefixCheck :: (Int, Int, Int, Int) -> String -> Bool
prefixCheck (r,g,y,b) [] = r == g && y == b
prefixCheck (r',g',y',b') (h:s) = ((<= 1) $ abs $ r - g) && ((<= 1) $ abs $ y - b)
&& prefixCheck (r,g,y,b) s
where r = if h == 'R' then r' + 1 else r'
g = if h == 'G' then g' + 1 else g'
y = if h == 'Y' then y' + 1 else y'
b = if h == 'B' then b' + 1 else b'
run :: Int -> IO ()
run 0 = putStr ""
run n = do
a <- getLine
print $ fullCheck a
run $ n - 1
main :: IO ()
main = do
b <- getLine
run $ read b
For reference as well, the question was
You are given a sequence of N balls in 4 colors: red, green, yellow and blue. The sequence is full of colors if and only if all of the following conditions are true:
There are as many red balls as green balls.
There are as many yellow balls as blue balls.
Difference between the number of red balls and green balls in every prefix of the sequence is at most 1.
Difference between the number of yellow balls and blue balls in every prefix of the sequence is at most 1.
Where a prefix of a string is any substring from the beginning to m where m is less than the size of the string
You have already got the answer in the comments why lists indexing performs linearly. But, if you are interested in a more Haskell style solution to the Hackerrank problem your referring to, even head-tail pattern matching is unnecessary. A more performant solution can be done with right folds:
import Control.Applicative ((<$>))
import Control.Monad (replicateM_)
solve :: String -> Bool
solve s = foldr go (\r g y b -> r == g && y == b) s 0 0 0 0
where
go x run r g y b
| 1 < abs (r - g) || 1 < abs (y - b) = False
| x == 'R' = run (r + 1) g y b
| x == 'G' = run r (g + 1) y b
| x == 'Y' = run r g (y + 1) b
| x == 'B' = run r g y (b + 1)
main :: IO ()
main = do
n <- read <$> getLine
replicateM_ n $ getLine >>= print . solve
I was playing around with Project Euler #34, and I wrote these functions:
import Data.Time.Clock.POSIX
import Data.Char
digits :: (Integral a) => a -> [Int]
digits x
| x < 10 = [fromIntegral x]
| otherwise = let (q, r) = x `quotRem` 10 in (fromIntegral r) : (digits q)
digitsByShow :: (Integral a, Show a) => a -> [Int]
digitsByShow = map (\x -> ord x - ord '0') . show
I thought that for sure digits has to be the faster one, as we don't convert to a String. I could not have been more wrong. I ran the two versions via pe034:
pe034 digitFunc = sum $ filter sumFactDigit [3..2540160]
where
sumFactDigit :: Int -> Bool
sumFactDigit n = n == (sum $ map sFact $ digitFunc n)
sFact :: Int -> Int
sFact n
| n == 0 = 1
| n == 1 = 1
| n == 2 = 2
| n == 3 = 6
| n == 4 = 24
| n == 5 = 120
| n == 6 = 720
| n == 7 = 5040
| n == 8 = 40320
| n == 9 = 362880
main = do
begin <- getPOSIXTime
print $ pe034 digitsByShow -- or digits
end <- getPOSIXTime
print $ end - begin
After compiling with ghc -O, digits consistently takes .5 seconds, while digitsByShow consistently takes .3 seconds. Why is this so? Why is the function which stays within Integer arithmetic slower, whereas the function which goes into string comparison is faster?
I ask this because I come from programming in Java and similar languages, where the % 10 trick of generating digits is way faster than the "convert to String" method. I haven't been able to wrap my head around the fact that converting to a string could be faster.
This is the best I can come up with.
digitsV2 :: (Integral a) => a -> [Int]
digitsV2 n = go n []
where
go x xs
| x < 10 = fromIntegral x : xs
| otherwise = case quotRem x 10 of
(q,r) -> go q (fromIntegral r : xs)
when compiled with -O2 and tested with Criterion
digits runs in 470.4 ms
digitsByShow runs in 421.8 ms
digitsV2 runs in 258.0 ms
results may vary
edit:
I am not sure why building the list like this helps so much.
But you can improve your codes speed by strictly evaluating quotRem x 10
You can do this with BangPatterns
| otherwise = let !(q, r) = x `quotRem` 10 in (fromIntegral r) : (digits q)
or with case
| otherwise = case quotRem x 10 of
(q,r) -> fromIntegral r : digits q
Doing this drops digits down to 323.5 ms
edit: time without using Criterion
digits = 464.3 ms
digitsStrict = 328.2 ms
digitsByShow = 259.2 ms
digitV2 = 252.5 ms
note: The criterion package measures software performance.
Let's investigate why #No_signal's solution is faster.
I made three runs of ghc:
ghc -O2 -ddump-simpl digits.hs >digits.txt
ghc -O2 -ddump-simpl digitsV2.hs >digitsV2.txt
ghc -O2 -ddump-simpl show.hs >show.txt
digits.hs
digits :: (Integral a) => a -> [Int]
digits x
| x < 10 = [fromIntegral x]
| otherwise = let (q, r) = x `quotRem` 10 in (fromIntegral r) : (digits q)
main = return $ digits 1
digitsV2.hs
digitsV2 :: (Integral a) => a -> [Int]
digitsV2 n = go n []
where
go x xs
| x < 10 = fromIntegral x : xs
| otherwise = let (q, r) = x `quotRem` 10 in go q (fromIntegral r : xs)
main = return $ digits 1
show.hs
import Data.Char
digitsByShow :: (Integral a, Show a) => a -> [Int]
digitsByShow = map (\x -> ord x - ord '0') . show
main = return $ digitsByShow 1
If you'd like to view the complete txt files, I placed them on ideone (rather than paste a 10000 char dump here):
digits.txt
digitsV2.txt
show.txt
If we carefully look through digits.txt, it appears that this is the relevant section:
lvl_r1qU = __integer 10
Rec {
Main.$w$sdigits [InlPrag=[0], Occ=LoopBreaker]
:: Integer -> (# Int, [Int] #)
[GblId, Arity=1, Str=DmdType <S,U>]
Main.$w$sdigits =
\ (w_s1pI :: Integer) ->
case integer-gmp-1.0.0.0:GHC.Integer.Type.ltInteger#
w_s1pI lvl_r1qU
of wild_a17q { __DEFAULT ->
case GHC.Prim.tagToEnum# # Bool wild_a17q of _ [Occ=Dead] {
False ->
let {
ds_s16Q [Dmd=<L,U(U,U)>] :: (Integer, Integer)
[LclId, Str=DmdType]
ds_s16Q =
case integer-gmp-1.0.0.0:GHC.Integer.Type.quotRemInteger
w_s1pI lvl_r1qU
of _ [Occ=Dead] { (# ipv_a17D, ipv1_a17E #) ->
(ipv_a17D, ipv1_a17E)
} } in
(# case ds_s16Q of _ [Occ=Dead] { (q_a11V, r_X12h) ->
case integer-gmp-1.0.0.0:GHC.Integer.Type.integerToInt r_X12h
of wild3_a17c { __DEFAULT ->
GHC.Types.I# wild3_a17c
}
},
case ds_s16Q of _ [Occ=Dead] { (q_X12h, r_X129) ->
case Main.$w$sdigits q_X12h
of _ [Occ=Dead] { (# ww1_s1pO, ww2_s1pP #) ->
GHC.Types.: # Int ww1_s1pO ww2_s1pP
}
} #);
True ->
(# GHC.Num.$fNumInt_$cfromInteger w_s1pI, GHC.Types.[] # Int #)
}
}
end Rec }
digitsV2.txt:
lvl_r1xl = __integer 10
Rec {
Main.$wgo [InlPrag=[0], Occ=LoopBreaker]
:: Integer -> [Int] -> (# Int, [Int] #)
[GblId, Arity=2, Str=DmdType <S,U><L,U>]
Main.$wgo =
\ (w_s1wh :: Integer) (w1_s1wi :: [Int]) ->
case integer-gmp-1.0.0.0:GHC.Integer.Type.ltInteger#
w_s1wh lvl_r1xl
of wild_a1dp { __DEFAULT ->
case GHC.Prim.tagToEnum# # Bool wild_a1dp of _ [Occ=Dead] {
False ->
case integer-gmp-1.0.0.0:GHC.Integer.Type.quotRemInteger
w_s1wh lvl_r1xl
of _ [Occ=Dead] { (# ipv_a1dB, ipv1_a1dC #) ->
Main.$wgo
ipv_a1dB
(GHC.Types.:
# Int
(case integer-gmp-1.0.0.0:GHC.Integer.Type.integerToInt ipv1_a1dC
of wild2_a1ea { __DEFAULT ->
GHC.Types.I# wild2_a1ea
})
w1_s1wi)
};
True -> (# GHC.Num.$fNumInt_$cfromInteger w_s1wh, w1_s1wi #)
}
}
end Rec }
I actually couldn't find the relevant section for show.txt. I'll work on that later.
Right off the bat, digitsV2.hs produces shorter code. That's probably a good sign for it.
digits.hs seems to be following this psuedocode:
def digits(w_s1pI):
if w_s1pI < 10: return [fromInteger(w_s1pI)]
else:
ds_s16Q = quotRem(w_s1pI, 10)
q_X12h = ds_s16Q[0]
r_X12h = ds_s16Q[1]
wild3_a17c = integerToInt(r_X12h)
ww1_s1pO = r_X12h
ww2_s1pP = digits(q_X12h)
ww2_s1pP.pushFront(ww1_s1pO)
return ww2_s1pP
digitsV2.hs seems to be following this psuedocode:
def digitsV2(w_s1wh, w1_s1wi=[]): # actually disguised as go(), as #No_signal wrote
if w_s1wh < 10:
w1_s1wi.pushFront(fromInteger(w_s1wh))
return w1_s1wi
else:
ipv_a1dB, ipv1_a1dC = quotRem(w_s1wh, 10)
w1_s1wi.pushFront(integerToIn(ipv1a1dC))
return digitsV2(ipv1_a1dC, w1_s1wi)
It might not be that these functions mutate lists like my psuedocode suggests, but this immediately suggests something: it looks as if digitsV2 is fully tail-recursive, whereas digits is actually not (may have to use some Haskell trampoline or something). It appears as if Haskell needs to store all the remainders in digits before pushing them all to the front of the list, whereas it can just push them and forget about them in digitsV2. This is purely speculation, but it is well-founded speculation.
On the odd chance, that someone has a brilliant idea...
I am not sure if there is a good way to generalize that.
EDIT: I think it might be nice to explain exactly what the inputs and outputs are. The code below is only how I approached the solution.
Inputs: data, recipe
data: set of string, string list here also called "set of named lists"
recipe: list of commands
Command Print (literal|list reference)
Adds the literal to the output or if it is a list reference, it adds the head of the referenced list to the output.
Command While (list reference)
when referenced list not empty --> next command
when referenced list empty --> skip entries in recipe list past the matching Wend.
Command Wend (list reference)
replace referenced list with tail (reference list)
when referenced list is empty, next command
when referenced list is not empty, next command is the matching while above.
Outputs: string list
The best answer is the implementation of that which is shortest and which allows to re-use that algorithm in new contexts.
This is not just a programming problem for the fun of it, btw. It is basically what happens if you try to implement data driven text templating.
The code below is my attempt to solve this problem.
The first code snippet is a non-generalized solution.
The second code snippet is an attempt to isolate the algorithm.
If you play with the code, simply paste the second snippet below the first snippet and both versions are working.
The whole topic is about understanding better how to separate the iteration algorithm from the rest of the code and then to simply apply it, in contrast of having all the other code within.
Would it not be great, if there was a way to abstract the way the statements are being processed and the looping of the while/wend, such,
that it can be reused in my main code, just as I keep re-using other "iteration schemes", such as List.map?
The commonalities between my main code and this study are:
An evolving "environment" which is threaded through all steps of the computation.
Collections, which need to be iterated in a well-formed nested manner. (Malformed would be: while x while y wend x wend y)
A series of "execution steps" form the body of each of those "while wend" loops.
Done in a "pure" manner. As you will note, nothing is mutable in the study. Want to keep it like that.
Each "While" introduces a new scope (as for binding values), which is discarded again, once the while loop is done.
So, I am looking for something like:
run: CommandClassifier -> commandExecutor -> Command list -> EnvType -> EnvType
where
CommandClassifier could be a function of the form Command -> NORMAL|LOOP_START|LOOP_END
and commandexecutor: Command -> EnvType -> EnvType
Of course, nesting of those while-blocks would not be limited to 2 (just tried to keep the testProgram() small).
SideNote: the "commands list" is an AST from a preceding parser run, but that should not really matter.
type MiniLanguage =
| Print of string
| While of string
| Wend of string
let testProgram =
[ Print("Hello, I am your Mini Language program")
While("names")
Print("<names>")
While("pets")
Print("<pets>")
Wend("pets")
Print("Done with pets.")
Wend("names")
Print("Done with names.")
]
type MiniEnvironment = { Bindings : Map<string,string>; Collections : Map<string, string list> }
let init collections =
{ Bindings = Map.empty; Collections = Map.ofList collections}
let bind n v env =
let newBindings =
env.Bindings
|> Map.remove n
|> Map.add n v
{ env with Bindings = newBindings; }
let unbind n env =
{ env with Bindings = Map.remove n env.Bindings; }
let bindingValue n env =
if env.Bindings.ContainsKey n then
Some(env.Bindings.Item n)
else
None
let consumeFirstFromCollection n env =
if env.Collections.ContainsKey n then
let coll = env.Collections.Item n
match coll with
| [] -> env |> unbind n
| _ ->
let first = coll.Head
let newCollections =
env.Collections
|> Map.remove n
|> Map.add n coll.Tail
{ env with Collections = newCollections }
|> bind n first
else failwith ("Unknown collection: " + n)
// All do functions take env - the execution environment - as last argument.
// All do functions return (a new) env as single return parameter.
let rec doPrint (s : string) env =
if s.StartsWith("<") && s.EndsWith(">") then
match bindingValue (s.Substring (1, s.Length - 2 )) env with
| Some(v) -> v
| _ -> s
else s
|> printfn "%s"
env
let rec skipPastWend name code =
match code with
| (Wend(cl) :: rest) when cl = name -> rest
| [] -> failwith "No Wend found!"
| (_ :: rest) -> skipPastWend name rest
let rec doWhileX name code env =
match code with
| (Print(s) :: rest) -> env |> (doPrint s) |> doWhileX name rest
| (While(cn) :: rest) -> env |> doWhile cn rest |> ignore; env |> doWhileX name (skipPastWend cn rest)
| (Wend(cn) :: rest) when cn = name -> env
| [] -> failwith ("While without Wend for: " + name)
| _ -> failwith ("nested while refering to same collection!")
and doWhile name code env =
let e0 = env |> consumeFirstFromCollection name
match bindingValue name e0 with
| Some(s) ->
e0 |> doWhileX name code |> doWhile name code
| None -> env
let rec run (program : MiniLanguage list) env =
match program with
| (Print(s) :: rest) -> env |> (doPrint s) |> run rest
| (While(cn) :: rest) ->
env
|> doWhile cn rest |> ignore
env |> run (skipPastWend cn program)
| (Wend(cn) :: rest) -> failwith "wend found in run()"
| [] -> env
let test() =
init [ "names", ["name1"; "name2"; "name3"; ]; "pets", ["pet1"; "pet2"] ]
|> run testProgram
|> printfn "%A"
(*
Running test() yields:
Hello, I am your Mini Language program
name1
pet1
pet2
Done with pets.
name2
pet1
pet2
Done with pets.
name3
pet1
pet2
Done with pets.
Done with names.
{Bindings = map [];
Collections =
map [("names", ["name1"; "name2"; "name3"]); ("pets", ["pet1"; "pet2"])];}
*)
Here my first version of isolating the algorithm. The number of callbacks is not entirely pretty. Can anyone come up with something simpler?
// The only function I had to "modify" to work with new "generalized" algorithm.
let consumeFirstFromCollection1 n env =
if env.Collections.ContainsKey n then
let coll = env.Collections.Item n
match coll with
| [] -> (env |> unbind n , false)
| _ ->
let first = coll.Head
let newCollections =
env.Collections
|> Map.remove n
|> Map.add n coll.Tail
({ env with Collections = newCollections }
|> bind n first , true)
else failwith ("Unknown collection: " + n)
type NamedList<'n,'t when 'n : comparison> = 'n * List<'t>
type Action<'a,'c> = 'c -> 'a -> 'a
type LoopPreparer<'a,'c> = 'c -> 'a -> 'a * bool
type CommandType = | RUN | BEGIN | END
type CommandClassifier<'c> = 'c -> CommandType
type Skipper<'c> = 'c -> List<'c> -> List<'c>
type InterpreterContext<'a,'c> =
{ classifier : CommandClassifier<'c>
executor : Action<'a,'c>
skipper : Skipper<'c>
prepareLoop : LoopPreparer<'a,'c>
isMatchingEnd : 'c -> 'c -> bool
}
let interpret (context : InterpreterContext<'a,'c>) (program : 'c list) (env : 'a) : 'a =
let rec loop front (code : 'c list) e =
let e0,hasData = e |> context.prepareLoop front
if hasData
then
e0
|> loop1 front (code)
|> loop front (code)
else e
and loop1 front code e =
match code with
| x :: more when (context.classifier x) = RUN ->
//printfn "RUN %A" x
e |> context.executor x |> loop1 front more
| x :: more when (context.classifier x) = BEGIN ->
//printfn "BEGIN %A" x
e |> loop x more |> ignore
e |> loop1 front (context.skipper x more)
| x :: more when (((context.classifier x) = END) && (context.isMatchingEnd front x)) -> /// && (context.isMatchingEnd front x)
//printfn "END %A" x
e
| [] -> failwith "No END."
| _ -> failwith "TODO: Not sure which case this is. But it is not a legal one!"
let rec interpr code e =
match code with
| [] -> e
| (first :: rest) ->
match context.classifier first with
| RUN -> env |> context.executor first |> interpr rest
| BEGIN ->
e |> loop first rest |> ignore
e |> interpr (context.skipper first rest)
| END -> failwith "END without BEGIN."
interpr program env
let test1() =
let context : InterpreterContext<MiniEnvironment,MiniLanguage> =
{ classifier = fun c-> match c with | MiniLanguage.Print(_) -> RUN | MiniLanguage.While(_) -> BEGIN | MiniLanguage.Wend(_) -> END;
executor = fun c env -> match c with | Print(s) -> doPrint s env | _ -> failwith "Not a known command.";
skipper = fun c cl -> match c with | While(n) -> skipPastWend n cl | _ -> failwith "first arg of skipper SHALL be While!"
prepareLoop = fun c env -> match c with | While(n) -> (consumeFirstFromCollection1 n env) | _ -> failwith "first arg of skipper SHALL be While!"
isMatchingEnd = fun cwhile cx -> match cwhile,cx with | (While(n),Wend(p)) when n = p -> true | _ -> false
}
init [ "names", ["name1"; "name2"; "name3"; ]; "pets", ["pet1"; "pet2"] ]
|> interpret context testProgram
|> printfn "%A"
When I trying to pass functor Board to Sudoku it has following error
What should i do in the .ml file to match the interface? How do i initialize the module Board and pass it into the Sudoku Module?
error: The implementation modularSudoku.ml
does not match the interface modularSudoku.cmi:
Modules do not match:
functor (B : Board1) ->
sig
val pick : B.grid -> (B.grid * B.location * B.grid) option
val update_at_loc :
B.grid -> B.location -> square -> B.grid option
val update_grid : B.grid -> B.location -> B.grid option
val is_solved : B.grid -> bool
val solve_sudoku : B.grid -> B.grid list -> B.grid list
val backtrack : B.grid list -> B.grid list
end
is not included in
functor
(Board : sig
type location
type grid
val first_location : location
val next : location -> location option
val same_row_col_block : location -> location -> bool
val get_square : grid -> location -> square
val change_square : grid -> location -> square -> grid
end) ->
sig
val pick :
Board.grid ->
(Board.grid * Board.location * Board.grid) option
val update_grid :
Board.grid -> Board.location -> Board.grid option
val is_solved : Board.grid -> bool
val solve_sudoku :
Board.grid -> Board.grid list -> Board.grid list
end
Modules do not match:
sig
type location
type grid
val first_location : location
val next : location -> location option
val same_row_col_block : location -> location -> bool
val get_square : grid -> location -> square
val change_square : grid -> location -> square -> grid
end
is not included in
Board1
Type declarations do not match:
type location
is not included in
type location = int * int
Here is Sudoku.mli file
type square = Picked of int | Possible of int list;;
module Sudoku :
functor (Board: sig
type location;;
type grid;;
val first_location: location;;
val next : location -> location option;;
val same_row_col_block : location -> location -> bool;;
val get_square : grid -> location -> square;;
val change_square : grid -> location -> square -> grid;;
end) -> (sig
open Board;;
val pick : grid -> (grid * location * grid) option;;
val update_grid : grid -> location -> grid option;;
val is_solved : grid -> bool;;
val solve_sudoku : grid -> grid list -> grid list;;
end)
;;
module Board1 : sig
type location = (int*int);;
type grid = square list;;
val first_location: location;;
val next : location -> location option;;
val same_row_col_block : location -> location -> bool;;
val get_square : grid -> location -> square;;
val change_square : grid -> location -> square -> grid;;
end
Here is Sudoku.ml file
type square = Picked of int | Possible of int list;;
let create_grid l = List.map (fun x -> match x with 0 -> Possible [1;2;3;4;5;6;7;8;9] | _ -> Picked x) l;;
(*test*)
let easyGrid = create_grid
[ 0 ; 6 ; 0 ; 0 ; 4 ; 0 ; 0 ; 0 ; 0
; 3 ; 0 ; 7 ; 1 ; 0 ; 9 ; 0 ; 0 ; 6
; 0 ; 9 ; 4 ; 2 ; 0 ; 5 ; 7 ; 0 ; 0
; 0 ; 3 ; 1 ; 0 ; 0 ; 0 ; 4 ; 0 ; 0
; 2 ; 0 ; 0 ; 4 ; 0 ; 7 ; 0 ; 0 ; 5
; 0 ; 0 ; 6 ; 0 ; 0 ; 0 ; 9 ; 7 ; 0
; 0 ; 0 ; 2 ; 3 ; 0 ; 8 ; 6 ; 1 ; 0
; 6 ; 0 ; 0 ; 9 ; 0 ; 2 ; 8 ; 0 ; 4
; 0 ; 0 ; 0 ; 0 ; 1 ; 0 ; 0 ; 9 ; 0];;
module type Board1 = sig
type location = (int*int);;
type grid = square list;;
val first_location: location;;
val next : location -> location option;;
val same_row_col_block : location -> location -> bool;;
val get_square : grid -> location -> square;;
val change_square : grid -> location -> square -> grid;;
end
module Board1 =
struct
type location = (int*int)
type grid = square list
let first_location = (0,0)
let next (i,j) =
if j+1 = 9 then
if i+1 = 9 then None
else Some (i+1,0)
else Some (i,j+1)
let same_row_col_block (i1,j1) (i2,j2) =
(i1 = i2) || (j1 = j2) || ((i1/3 = i2/3) && (j1/3 = j2/3))
let get_square grid (i, j) = List.nth grid (9*i + j)
let change_square grid (i, j) square =
let k = i * 9 + j in
let rec helper t acc n =
if n = k then List.rev_append acc (square :: (List.tl t))
else helper (List.tl t) (List.hd t :: acc) (n+1) in
helper grid [] 0
end;;
module Sudoku =
functor (B:Board1)->
struct
let pick grid =
let rec helper loc =
match B.get_square grid loc with
| Picked _ -> (match B.next loc with
| None -> None
| Some loc1 -> helper loc1)
| Possible l ->
(match l with
| [] -> None
| x :: xs -> let new_grid = B.change_square grid loc (Picked x) in
let choice_grid = B.change_square grid loc (Possible xs) in
Some (new_grid, loc, choice_grid)) in
helper B.first_location
let update_at_loc grid loc square =
let square1 = B.get_square grid loc in
match square,square1 with
| Picked x, Picked y -> if x = y then None else Some grid
| Picked x, Possible l ->
if List.mem x l
then let l' = List.filter (fun y -> not (y = x)) l in
if List.length l' == 0 then None else Some (B.change_square grid loc (Possible l'))
else Some grid
| _ -> assert false
let update_grid grid loc =
let square = B.get_square grid loc in
let apply_constraint loc1 grid =update_at_loc grid loc1 square in
let rec help loc1 grid =
let g =
if loc = loc1
then Some grid
else if B.same_row_col_block loc loc1
then apply_constraint loc1 grid
else Some grid in
match g with
| None -> None
| Some newgrid ->
(match B.next loc1 with
| None -> g
| Some loc2 -> help loc2 newgrid) in
help B.first_location grid
let is_solved grid =
let rec helper loc =
match B.get_square grid loc with
| Possible _ -> false
| Picked _ -> match B.next loc with
| None -> true
| Some loc1 -> helper loc1 in
helper B.first_location
let rec solve_sudoku grid choices =
match pick grid with
| None -> if is_solved grid then (*let () = print_sudoku grid in*) grid :: backtrack choices
else backtrack choices
| Some (g,loc,ch) ->
(match update_grid g loc with
| None -> backtrack (ch::choices)
| Some grid -> (*let () = print_sudoku grid in*)
solve_sudoku grid (ch::choices))
and backtrack choices =
match choices with
| [] -> []
| g :: grids -> solve_sudoku g grids
end
;;
In your .mli, the functor Sudoku is specified to expect an argument module with types location and grid, but with no restriction on what these types are. For example, according to the spec in the .mli, I should be able to apply
module A = struct type location = bool type grid = unit (* ... *) end
module S = Sudoku(A)
However, in the .ml you define the functor such that it requires the argument to have these types equal to int * int and square list, respectively. Clearly, that is more restrictive (fewer modules match that argument signature, in particular, not the above A), and hence the functor itself does not match the more liberal specification in the .mli (this is also known as contravariance).
Is there a reason why you don't just annotate the functor parameter B with the same signature Board1 in the .mli as well? Then it would clearly work.