2009/08/01

Add Conditional, Logical and Ternary Operator to the Calculator

To enable calculator to use conditional branching, add conditional operator.
It is good to add boolean type to calculator, but for my laziness, it is easy to use only Double type, and use 0.0 for express false and any other value to true.
Next, add logical-and(&&) and logical-or(||) operator. Use these operator, we can imitate conditional branching:
cond && then || else

but when 'then' value is 0, this return 'else' value. So I must add ternary operator.


import Text.ParserCombinators.Parsec
import Text.ParserCombinators.Parsec.Expr
import qualified Text.ParserCombinators.Parsec.Token as P
import Text.ParserCombinators.Parsec.Language
import Control.Monad (when)
import System.IO

type Environment = [(String, Double)]

doAssign :: String -> Double -> Environment -> Environment
doAssign var val env = (var, val) : filter ((/= var) . fst) env

data MyParserState =
MyParserState {
global :: Environment
}
deriving (Show)

type MyParser a = GenParser Char MyParserState a

lexer :: P.TokenParser MyParserState
lexer = P.makeTokenParser (haskellDef { reservedOpNames = ["*","/","+","-","**", "==", "/=", "<", "<=", ">", ">=", "&&", "||", "?", ":"] })

naturalOrFloat = P.naturalOrFloat lexer
parens = P.parens lexer
reservedOp = P.reservedOp lexer
identifier = P.identifier lexer
lexeme = P.lexeme lexer

expr = assignExpr

assignExpr :: MyParser Double
assignExpr = try(assign) <|> condExpr
where
assign = do
var <- identifier
lexeme $ char '='
e <- expr

updateState $ \st -> st{ global = doAssign var e (global st) }
return e

condExpr :: MyParser Double
condExpr = try(cond) <|> expr'
where
cond = do
c <- expr'
lexeme $ char '?'
t <- expr
lexeme $ char ':'
e <- expr
return $ if isTrue c then t else e

expr' :: MyParser Double
expr' = buildExpressionParser table factor <?> "expression"
where
table = [
[unary "-" negate, unary "+" id],
[op "**" (**) AssocRight],
[op "*" (*) AssocLeft, op "/" (/) AssocLeft],
[op "+" (+) AssocLeft, op "-" (-) AssocLeft],
[op "==" (cmp (==)) AssocNone, op "/=" (cmp (/=)) AssocNone, op "<" (cmp (<)) AssocNone, op "<=" (cmp (<=)) AssocNone, op ">" (cmp (>)) AssocLeft, op ">=" (cmp (>=)) AssocNone],
[op "&&" (logiand) AssocLeft],
[op "||" (logior) AssocLeft]
]
op s f assoc = Infix (do{ reservedOp s; return f } <?> "operator") assoc
unary s f = Prefix (do{ reservedOp s; return f })
cmp op x y = if x `op` y then true else false
logiand x y = if isFalse x then x else y
logior x y = if isTrue x then x else y

false = 0.0
true = 1.0
isFalse = (== false)
isTrue = (/= false)

factor :: MyParser Double
factor = parenedExpr <|> floatLiteral <|> funcallOrVarref <?> "factor"

parenedExpr :: MyParser Double
parenedExpr = parens expr

floatLiteral :: MyParser Double
floatLiteral = do
norf <- naturalOrFloat
case norf of
Left i -> return $ fromInteger i
Right f -> return $ f

funcallOrVarref :: MyParser Double
funcallOrVarref = do
name <- identifier
do {
params <- lexeme formalparams;
case (applyFunc name params) of
Right v -> return v
Left err -> fail err
} <|> do
st <- getState;
case lookup name (global st) of
Nothing -> fail $ "undefined variable: " ++ name
Just v -> return v

formalparams :: MyParser [Double]
formalparams = do
lexeme $ char '('
params <- expr `sepBy` lexeme (char ',')
char ')'
return params

applyFunc :: String -> [Double] -> Either String Double
applyFunc fname params = call $ lookup fname functbl
where
functbl = [
("sin", (1, apply1 sin)),
("cos", (1, apply1 cos)),
("tan", (1, apply1 tan)),
("log", (1, apply1 log)),
("sqrt", (1, apply1 sqrt))
]

call Nothing = Left $ fname ++ ": no function"
call (Just (argnum, fn))
| length params /= argnum = Left $ fname ++ ": illegal argnum, " ++ show (length params) ++ " for " ++ show argnum
| otherwise = Right $ fn params

apply1 f [x] = f x
apply2 f [x,y] = f x y

repl :: String -> (String -> Bool) -> (String -> st -> (String, st)) -> st -> IO st
repl prompt bQuit eval = loop
where
loop st = putStr prompt >> getLine >>= act st
act st s
| bQuit s = return st
| otherwise = do
let (res, st') = eval s st
putStrLn res
loop st'

calc :: MyParserState -> IO MyParserState
calc = repl "> " (== ":q") eval
where
eval line st = do
case (runParser stmt st "" line) of
Left err -> (show err, st)
Right (v, st') -> (show v, st')
stmt = do
e <- expr
eof
st <- getState
return (e, st)

initialState = MyParserState genv
where
genv = [
("pi", pi)
]

main = hSetBuffering stdout NoBuffering >> putStrLn "type ':q' to quit." >> calc initialState >>= print >> putStrLn "Bye"

2009/07/31

Add Variable Assignment and Reference to Calculator

To add variable assignment and reference to calculator, we must add parser state.


import Text.ParserCombinators.Parsec
import Text.ParserCombinators.Parsec.Expr
import qualified Text.ParserCombinators.Parsec.Token as P
import Text.ParserCombinators.Parsec.Language
import Control.Monad (when)
import System.IO

type Environment = [(String, Double)]

doAssign :: String -> Double -> Environment -> Environment
doAssign var val env = (var, val) : filter ((/= var) . fst) env

data MyParserState =
MyParserState {
global :: Environment
}
deriving (Show)

type MyParser a = GenParser Char MyParserState a

lexer :: P.TokenParser MyParserState
lexer = P.makeTokenParser (haskellDef { reservedOpNames = ["*","/","+","-","**"] })

naturalOrFloat = P.naturalOrFloat lexer
parens = P.parens lexer
reservedOp = P.reservedOp lexer
identifier = P.identifier lexer
lexeme = P.lexeme lexer

expr = assignExpr

assignExpr :: MyParser Double
assignExpr = try(assign) <|> expr'
where
assign = do
var <- identifier
lexeme $ char '='
e <- expr

updateState $ \st -> st{ global = doAssign var e (global st) }
return e

expr' :: MyParser Double
expr' = buildExpressionParser table factor <?> "expression"
where
table = [
[unary "-" negate, unary "+" id],
[op "**" (**) AssocRight],
[op "*" (*) AssocLeft, op "/" (/) AssocLeft],
[op "+" (+) AssocLeft, op "-" (-) AssocLeft]
]
op s f assoc = Infix (do{ reservedOp s; return f } <?> "operator") assoc
unary s f = Prefix (do{ reservedOp s; return f })

factor :: MyParser Double
factor = parenedExpr <|> floatLiteral <|> funcallOrVarref <?> "factor"

parenedExpr :: MyParser Double
parenedExpr = parens expr

floatLiteral :: MyParser Double
floatLiteral = do
norf <- naturalOrFloat
case norf of
Left i -> return $ fromInteger i
Right f -> return $ f

funcallOrVarref :: MyParser Double
funcallOrVarref = do
name <- identifier
do {
params <- lexeme formalparams;
case (applyFunc name params) of
Right v -> return v
Left err -> fail err
} <|> do
st <- getState;
case lookup name (global st) of
Nothing -> fail $ "undefined variable: " ++ name
Just v -> return v

formalparams :: MyParser [Double]
formalparams = do
lexeme $ char '('
params <- expr `sepBy` lexeme (char ',')
char ')'
return params

applyFunc :: String -> [Double] -> Either String Double
applyFunc fname params = call $ lookup fname functbl
where
functbl = [
("sin", (1, apply1 sin)),
("cos", (1, apply1 cos)),
("tan", (1, apply1 tan)),
("log", (1, apply1 log)),
("sqrt", (1, apply1 sqrt))
]

call Nothing = Left $ fname ++ ": no function"
call (Just (argnum, fn))
| length params /= argnum = Left $ fname ++ ": illegal argnum, " ++ show (length params) ++ " for " ++ show argnum
| otherwise = Right $ fn params

apply1 f [x] = f x
apply2 f [x,y] = f x y

repl :: String -> (String -> Bool) -> (String -> st -> (String, st)) -> st -> IO st
repl prompt bQuit eval = loop
where
loop st = putStr prompt >> getLine >>= act st
act st s
| bQuit s = return st
| otherwise = do
let (res, st') = eval s st
putStrLn res
loop st'

calc :: MyParserState -> IO MyParserState
calc = repl "> " (== ":q") eval
where
eval line st = do
case (runParser stmt st "" line) of
Left err -> (show err, st)
Right (v, st') -> (show v, st')
stmt = do
e <- expr
eof
st <- getState
return (e, st)

initialState = MyParserState genv
where
genv = [
("pi", pi)
]

main = hSetBuffering stdout NoBuffering >> putStrLn "type ':q' to quit." >> calc initialState >>= print >> putStrLn "Bye"




  • To make parser to have state, use "type MyParser a = GenParser Char MyParserState a".
  • Assignment has to change parser's state, so it can't into buildExpressionParser's table. So add assignExpr parser.
  • For fail to assign parser, use try for retry parse.
  • For function's formal parameter parser, using sepBy make parser much simpler.
  • Environment use assoc-list for easy to implement, but it is better to use hash table, maybe.
  • Calculator must update state for each input, so change repl.

Add Embed Function to Calculator

Add embed functions (sin, cos, tan, log, sqrt), and enable to call it.


import Text.ParserCombinators.Parsec
import Text.ParserCombinators.Parsec.Expr
import qualified Text.ParserCombinators.Parsec.Token as P
import Text.ParserCombinators.Parsec.Language
import Control.Monad (when)
import System.IO

lexer :: P.TokenParser ()
lexer = P.makeTokenParser (haskellDef { reservedOpNames = ["*","/","+","-","**"] })

naturalOrFloat = P.naturalOrFloat lexer
parens = P.parens lexer
reservedOp = P.reservedOp lexer
identifier = P.identifier lexer
lexeme = P.lexeme lexer

expr :: Parser Double
expr = buildExpressionParser table factor <?> "expression"
where
table = [
[unary "-" negate, unary "+" id],
[op "**" (**) AssocRight],
[op "*" (*) AssocLeft, op "/" (/) AssocLeft],
[op "+" (+) AssocLeft, op "-" (-) AssocLeft]
]
op s f assoc = Infix (do{ reservedOp s; return f } <?> "operator") assoc
unary s f = Prefix (do{ reservedOp s; return f })

factor :: Parser Double
factor =
do {
parens expr;
} <|> do {
norf <- naturalOrFloat;
case norf of
Left i -> return $ fromInteger i
Right f -> return $ f
} <|>
funcall
<?>
"factor"

funcall :: Parser Double
funcall =
do {
fname <- identifier;
params <- lexeme formalparams;
case (applyFunc fname params) of
Right v -> return v
Left err -> fail err
}

formalparams :: Parser [Double]
formalparams = lexeme (char '(') >> params False
where
params bComma =
do {
char ')';
return [];
} <|> do {
when bComma $ lexeme (char ',') >> return ();
e <- expr;
r <- params True;
return $ e : r;
}

applyFunc :: String -> [Double] -> Either String Double
applyFunc fname params = call $ lookup fname functbl
where
functbl = [
("sin", (1, apply1 sin)),
("cos", (1, apply1 cos)),
("tan", (1, apply1 tan)),
("log", (1, apply1 log)),
("sqrt", (1, apply1 sqrt))
]

call Nothing = Left $ fname ++ ": no function"
call (Just (argnum, fn))
| length params /= argnum = Left $ fname ++ ": illegal argnum, " ++ show (length params) ++ " for " ++ show argnum
| otherwise = Right $ fn params

apply1 f [x] = f x
apply2 f [x,y] = f x y

repl :: String -> (String -> Bool) -> (String -> String) -> IO ()
repl prompt bQuit eval = loop
where
loop = do
putStr prompt
s <- getLine
if bQuit s
then return ()
else putStrLn (eval s) >> loop

calc :: IO ()
calc = repl "> " (== ":q") (tostring . parse stmt "")
where
tostring (Right v) = show v
tostring (Left err) = show err
stmt = do
e <- expr
eof
return e

main = hSetBuffering stdout NoBuffering >> putStrLn "type ':q' to quit." >> calc >> putStrLn "Bye"



  • Add factor to funcall parser.
  • Use lexeme to make strip whitespace parser.
  • Embed functions are stored in fixed table and can't add runtime.

Make Simple Calculator Using Parsec

Make simple calculator using Parsec in Haskell. The calculator can use +, -, *, / and **(power).


import Text.ParserCombinators.Parsec
import Text.ParserCombinators.Parsec.Expr
import qualified Text.ParserCombinators.Parsec.Token as P
import Text.ParserCombinators.Parsec.Language
import System.IO

lexer :: P.TokenParser ()
lexer = P.makeTokenParser (haskellDef { reservedOpNames = ["*","/","+","-","**"] })

naturalOrFloat = P.naturalOrFloat lexer
parens = P.parens lexer
reservedOp = P.reservedOp lexer

expr :: Parser Double
expr = buildExpressionParser table factor <?> "expression"
where
table = [
[unary "-" negate, unary "+" id],
[op "**" (**) AssocRight],
[op "*" (*) AssocLeft, op "/" (/) AssocLeft],
[op "+" (+) AssocLeft, op "-" (-) AssocLeft]
]
op s f assoc = Infix (do{ reservedOp s; return f } <?> "operator") assoc
unary s f = Prefix (do{ reservedOp s; return f })

factor :: Parser Double
factor =
do {
parens expr;
} <|> do {
norf <- naturalOrFloat;
case norf of
Left i -> return $ fromInteger i
Right f -> return $ f
} <?>
"factor"

repl :: String -> (String -> Bool) -> (String -> String) -> IO ()
repl prompt bQuit eval = loop
where
loop = do
putStr prompt
s <- getLine
if bQuit s
then return ()
else putStrLn (eval s) >> loop

calc :: IO ()
calc = repl "> " (== ":q") (tostring . parse stmt "")
where
tostring (Right v) = show v
tostring (Left err) = show err
stmt = do
e <- expr
eof
return e

main = hSetBuffering stdout NoBuffering >> putStrLn "type ':q' to quit." >> calc >> putStrLn "Bye"



2009/04/25

Using DirectX from Haskell


I try to use DirectX from Haskell. I heard that there were a bindings made by Esa Ilari Vuokko. I got archive, but I can't found the homepage or repositry now, archive only. Anyway, I try to use that bindins.

Prepare


This library are for MinGW/MSYS, and need transformation DirectX library for MinGW:
cd $DXSDK
mkdir Mingw
cd Mingw
cp ../Lib/x86/*.lib .
rm DxErr*.lib
ls | xargs -n 1 reimp


Build


When I tried to compile Setup.hs, raised compile error. The library was made on GHC 6.4, and Its need to be change:
 main = defaultMainWithHooks defaultUserHooks{preConf=conf, postConf=ok}
where
- ok _ _ _ _ = return ExitSuccess
+ ok _ _ _ _ = return ()


Building base


When 'install', raise no 'LICENSE' file error. Copy it from root.

Building d3d


Need change d3d/DirectX9/D3D/Utility/Init.hs:
{- Comment out:
import Graphics.Win32 ( WindowClosure, HWND, mkClassName, loadIcon,
, loadCursor, createSolidBrush, rgb, registerClass
, showWindow, updateWindow, sendMessage, WPARAM
, LPARAM, LRESULT, WindowMessage, defWindowProc
, createWindow, getMessage, translateMessage
, dispatchMessage, allocaMessage )
import Graphics.Win32 ( iDI_APPLICATION, iDC_ARROW, cS_VREDRAW, cS_HREDRAW
, wS_OVERLAPPEDWINDOW, sW_SHOWNORMAL, wM_DESTROY
, wM_QUIT, wM_KEYDOWN, vK_ESCAPE )
-}
import Graphics.Win32


Building d3dx


No problems.

Make test application


Ok, the library was installed. I had tried making DirectX's Tutorial 2: Rendering Vertices:

I got it! I want to make more sample.

2009/04/16

'Super Nario' move to github

I had making 'Super Nario Bros.' in Haskell.
YouTube - Making 'Super Nario Bros.' in Haskell:

Haskellで敵を踏み潰したりするゲームを作ってみた‐ニコニコ動画:


Now, source codes move to Github's repository: http://github.com/mokehehe/monao/tree/master.

And change name 'Nario' to 'Monao'. 'Monao' means 'Monadic man' in Japanese. Sounds like haskellish, huh? Please check it out, and give me advices!

Using SDL-mixer in Haskell

I had tried to use SDL-mixer in Haskell several times, but always I hit the wall.
Today, I found a good tutorial for SDL-mixer in C: SDL_Mixer Tutorial, and I try same sequence in Haskell again.
But unfortunately, I've got some error.

$ ghc --make sdl-mixer-test2.hs
Linking sdl-mixer-test2 ...
/home/foo/.cabal/lib/SDL-mixer-0.5.2/ghc-6.8.2/libHSSDL-mixer-0.5.2.a(Samples.o): In function `s5wy_info':
(.text+0x25d): undefined reference to `Mix_LoadWAV'
collect2: ld はステータス 1 で終了しました

It said, undefined reference to `Mix_LoadWAV'. In /usr/local/include/SDL/SDL_mixer.h,

#define Mix_LoadWAV(file) Mix_LoadWAV_RW(SDL_RWFromFile(file, "rb"), 1)

There are no function body. Maybe it has changed something.
So I update SDL-mixer and SDL to 0.5.5, and try again, then got it!

Here are sample in Haskell, like original C version: