mokehehe's blog

Add Conditional, Logical and Ternary Operator to the Calculator

2009-08-01T00:02:00.004+09:00

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"

Add Variable Assignment and Reference to Calculator

2009-07-31T23:38:00.001+09:00

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

2009-07-31T23:18:00.002+09:00

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

2009-07-31T22:50:00.005+09:00

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"

It is easy to make tokenizer to use makeTokenParser.
Using buildExpressionParser, it is easy to make expression parser which has priority.
For printing prompt, use "hSetBuffering stdout NoBuffering" for no buffering.

Using DirectX from Haskell

2009-04-25T14:40:00.008+09:00

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.

'Super Nario' move to github

2009-04-16T21:34:00.004+09:00

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

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

2009-04-16T02:02:00.004+09:00

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:

A Picture Language on BiwaScheme

2009-04-09T08:52:00.013+09:00

I am playing on BiwaScheme these days. BiwaScheme is the hotest implementation of Scheme on JavaScript. It run on your web browser!
It has no functional references, specifications, and less runtime debug information, but maybe it could fix soon, and it almost works along to R6RS!
Because of its famility of JavaScript, it is easy to use DHTML. So I decidede to make "A Picture Language" in SICP 2.2.4. It was easy job. I wrote a little Scheme code, and a little HTML. Got it!

A Picture Language

It's run on full scheme feature, so you can make any image that you want. If you want to draw a picture of mandara, just put code and push 'draw' button:


(define (transform-painter painter origin corner1 corner2)
  (lambda (frame)
    (let ((m (frame-coord-map frame)))
      (let ((new-origin (m origin)))
        (painter
         (make-frame new-origin
                     (sub-vect (m corner1) new-origin)
                     (sub-vect (m corner2) new-origin)))))))

(define (flip-vert painter)
  (transform-painter painter
                     (make-vect 0.0 1.0)
                     (make-vect 1.0 1.0)
                     (make-vect 0.0 0.0)))

(define (flip-horiz painter)
  (transform-painter painter
                     (make-vect 1.0 0.0)
                     (make-vect 0.0 0.0)
                     (make-vect 1.0 1.0)))

(define (compose-painters . painters)
  (lambda (frame)
    (for-each (lambda (painter)
                (painter frame))
              painters)))

(define (beside painter1 painter2)
  (let ((split-point (make-vect 0.5 0.0)))
    (let ((paint-left
           (transform-painter painter1
                              (make-vect 0.0 0.0)
                              split-point
                              (make-vect 0.0 1.0)))
          (paint-right
           (transform-painter painter2
                              split-point
                              (make-vect 1.0 0.0)
                              (make-vect 0.5 1.0))))
      (compose-painters paint-left paint-right))))

(define (below painter1 painter2)
  (let ((split-point (make-vect 0.0 0.5)))
    (let ((paint-top
           (transform-painter painter1
                              (make-vect 0.0 0.0)
                              (make-vect 1.0 0.0)
                              split-point))
          (paint-bottom
           (transform-painter painter2
                              split-point
                              (make-vect 1.0 0.5)
                              (make-vect 0.0 1.0))))
      (compose-painters paint-top paint-bottom))))

(define (split f1 f2)
  (define (recur painter n)
    (if (= n 0)
        painter
      (let ((smaller (recur painter (- n 1))))
        (f1 painter (f2 smaller smaller)))))
  recur)

(define right-split (split beside below))
(define up-split (split below beside))

(define (corner-split painter n)
  (if (= n 0)
      painter
      (let ((up (up-split painter (- n 1)))
            (right (right-split painter (- n 1))))
        (let ((top-left (beside up up))
              (bottom-right (below right right))
              (corner (corner-split painter (- n 1))))
          (beside (below painter top-left)
                  (below bottom-right corner))))))

(define (mirror painter)
  (below (flip-vert (beside (flip-horiz painter) painter))
         (beside (flip-horiz painter) painter)))

(mirror (corner-split %image 2))

You want to use BiwaScheme? Check github's master repository and pull it!

hsSDL can't install on GHC 6.10.2, Windows/Cygwin

2009-04-09T04:11:00.007+09:00

I install newest version of GHC, 6.10.2, and I try to use Graphics.UI.SDL, but I can't.
I didn't use cabal, tried to install manually. But it occured error in building C source part.

I edited sdl.cabal, add

Include-Dirs: C:\SDL-1.2.12\include
Extra-Lib-Dirs: C:\SDL-1.2.12\lib

and change

Extra-Libraries: SDL.dll SDLmain

"runghc Setup.lhs configure" is passed safely, but in "runghc Setup.lhs build", I got these errors:

$ runghc Setup.lhs build

Setup.lhs:2:2:
Warning: In the use of `defaultUserHooks'
         (imported from Distribution.Simple):
         Deprecated: "Use simpleUserHooks or autoconfUserHooks, unless you n
eed Cabal-1.2
         compatibility in which case you must stick with defaultUserHooks"
Preprocessing library SDL-0.5.5...
dist\build\Graphics\UI\SDL\General_hsc_make.o:General_hsc_make.c:(.text+0x0): mu
ltiple definition of `main'
C:\ghc\ghc-6.10.2/gcc-lib/libmingw32.a(main.o):main.c:(.text+0x0): first defined
here
C:\ghc\ghc-6.10.2/gcc-lib/libmingw32.a(main.o):main.c:(.text+0x104): undefined r
eference to `WinMain@16'
collect2: ld returned 1 exit status
linking dist\build\Graphics\UI\SDL\General_hsc_make.o failed
command was: C:\ghc\ghc-6.10.2\gcc.exe -BC:\ghc\ghc-6.10.2\gcc-lib -IC:\ghc\ghc-
6.10.2\include\mingw -LC:\temp\SDL-1.2.12\lib -lSDL.dll -lSDLmain -L/cygdrive/c/
cygwin/usr/local/lib -lSDLmain -lSDL -lmingw32 -mwindows -LC:\ghc\ghc-6.10.2\bas
e-4.1.0.0 -lwsock32 -lmsvcrt -lkernel32 -luser32 -lshell32 -LC:\ghc\ghc-6.10.2\i
nteger-0.1.0.1 -LC:\ghc\ghc-6.10.2\ghc-prim-0.1.0.0 -LC:\ghc\ghc-6.10.2 -LC:\ghc
\ghc-6.10.2/gcc-lib -lm -lffi -lgmp -lwsock32 dist\build\Graphics\UI\SDL\General
_hsc_make.o -o dist\build\Graphics\UI\SDL\General_hsc_make.exe

What am I wrong?

I checked path, configure, and tried several times. But it never succeeded. So, I uninstall GHC 6.10.2, and downgrade to GHC 6.8.3, and try same sequence. then I can install. Why? Is there anyone to have same trouble?

In the past, when I tried to use Graphics.UI.GLUT, I've got same kinds of trouble. I want to use GHC 6.10.2, but its happens, I can't.

AO bench in Haskell

2009-04-01T21:46:00.012+09:00

AO bench (Ambient Occlusion benchmark) is a test program for any computer languages. It is simple algorithm, and get nifty image.
I wrote AO bench in Haskell. First, I translated from C source, and got worked. But it was not good at all. It's not Haskell way. Haskell program must be clean, easy to read, and compact.
I refactor it, so bit suit for Haskell way. But then, it got more slowly. Maybe I make anything to leak of memory. Please help me, and make Haskell fastest in all of the languages!


module Main () where

import System (getArgs)
import System.IO (withBinaryFile, IOMode(..), hPutStrLn)
import System.Random.Mersenne
import Data.Maybe (catMaybes, listToMaybe)
import Data.List (sort)
import qualified Data.ByteString.Char8 as B

data Vec = Vec {
      x :: Double,
      y :: Double,
      z :: Double
    } deriving (Eq)

data Isect = Isect {
      isect_t :: Double,
      isect_p :: Vec,
      isect_n :: Vec
    } deriving (Eq)

instance Ord Isect where
    i1 < i2   = isect_t i1 < isect_t i2
    i1 > i2   = isect_t i1 > isect_t i2
    i1 <= i2  = isect_t i1 <= isect_t i2
    i1 >= i2  = isect_t i1 >= isect_t i2

data Sphere = Sphere {
      sphere_center :: Vec,
      sphere_radius :: Double
    }

data Plane = Plane {
      plane_p :: Vec,
      plane_n :: Vec
    }

data Ray = Ray {
      ray_org :: Vec,
      ray_dir :: Vec
    }

type Point = (Int, Int)

-- Floatint-point Color
type FColor = Vec

sq :: Num a => a -> a
sq x = x * x

clamp :: Ord a => a -> a -> a -> a
clamp lower upper = min upper . max lower

i2d :: Int -> Double
i2d = toEnum

fpcol2icol vec = (f2i (x vec), f2i (y vec), f2i (z vec))
f2i = clamp 0 255 . floor . (* 255.99)

drand48 :: IO Double
drand48 = getStdGen >>= random

justIf :: a -> Bool -> Maybe a
val `justIf` cond
    | cond      = Just val
    | otherwise = Nothing

zerovec = Vec { x = 0, y = 0, z = 0 }
white = Vec { x = 1, y = 1, z = 1 }

v0 `vadd` v1 = Vec (x v0 + x v1) (y v0 + y v1) (z v0 + z v1)
v0 `vsub` v1 = Vec (x v0 - x v1) (y v0 - y v1) (z v0 - z v1)
v0 `vscale` s = Vec (x v0 * s) (y v0 * s) (z v0 * s)

v0 `vdot` v1 = (x v0 * x v1) + (y v0 * y v1) + (z v0 * z v1)

v0 `vcross` v1 = Vec cx cy cz
    where
      cx = y v0 * z v1 - z v0 * y v1
      cy = z v0 * x v1 - x v0 * z v1
      cz = x v0 * y v1 - y v0 * x v1

vlength c = sqrt $ c `vdot` c

vnormalize c
    | l > 1.0e-17        = c `vscale` (1.0 / l)
    | otherwise                = c
    where
      l = vlength c

vaverage :: [Vec] -> Vec
vaverage vecs = vsum `vscale` (1.0 / i2d vecnum)
    where vsum = foldl vadd zerovec vecs
          vecnum = length vecs

ray_sphere_intersect :: Ray -> Sphere -> Maybe Isect
ray_sphere_intersect ray sphere =
    isect `justIf` (d > 0.0 && t > 0.0)
    where
      rs = ray_org ray `vsub` sphere_center sphere
      b = rs `vdot` ray_dir ray
      c = rs `vdot` rs - sq (sphere_radius sphere)
      d = b * b - c
      t = -b - sqrt d
      hitpos = ray_org ray `vadd` (ray_dir ray `vscale` t)
      isect = Isect {
                isect_t = t,
                isect_p = hitpos,
                isect_n = vnormalize $ hitpos `vsub` sphere_center sphere
              }

ray_plane_intersect :: Ray -> Plane -> Maybe Isect
ray_plane_intersect ray plane =
    isect `justIf` (abs v >= 1.0e-17 && t > 0)
    where
      d = -(plane_p plane `vdot` plane_n plane)
      v = ray_dir ray `vdot` plane_n plane
      t = -(ray_org ray `vdot` plane_n plane + d) / v
      isect = Isect {
                isect_t = t,
                isect_p = ray_org ray `vadd` (ray_dir ray `vscale` t),
                isect_n = plane_n plane
              }

orthoBasis :: Vec -> (Vec, Vec, Vec)
orthoBasis n = (basis0, basis1, basis2)
    where
      basis2 = n
      basis1'
          | x n < 0.6 && x n > -0.6  = Vec { x = 1, y = 0, z = 0 }
          | y n < 0.6 && y n > -0.6  = Vec { x = 0, y = 1, z = 0 }
          | z n < 0.6 && z n > -0.6  = Vec { x = 0, y = 0, z = 1 }
          | otherwise                = Vec { x = 1, y = 0, z = 0 }
      basis0 = vnormalize $ basis1' `vcross` basis2
      basis1 = vnormalize $ basis2 `vcross` basis0

hemisphereDirectionRay :: Vec -> Vec -> Double -> Double -> Ray
hemisphereDirectionRay p n r1 r2 =
    Ray { ray_org = p, ray_dir = r }
    where
      theta = sqrt r1
      phi = 2.0 * pi * r2
      v = Vec {
            x = cos phi * theta,
            y = sin phi * theta,
            z = sqrt $ 1.0 - sq theta
          }
      -- local -> global
      (basis0, basis1, basis2) = orthoBasis n
      r = Vec {
            x = x v * x basis0 + y v * x basis1 + z v * x basis2,
            y = x v * y basis0 + y v * y basis1 + z v * y basis2,
            z = x v * z basis0 + y v * z basis1 + z v * z basis2
          }

randomHemisphereRay :: Vec -> Vec -> IO Ray
randomHemisphereRay p n = do
  r1 <- drand48
  r2 <- drand48
  return $ hemisphereDirectionRay p n r1 r2

data Object = ObjSphere Sphere | ObjPlane Plane

findRayObjIntersect :: Ray -> Object -> Maybe Isect
findRayObjIntersect ray (ObjSphere sphere) = ray_sphere_intersect ray sphere
findRayObjIntersect ray (ObjPlane  plane)  = ray_plane_intersect  ray plane

isHitOccluder :: [Object] -> Ray -> Bool
isHitOccluder objs ray =
    not $ null $ catMaybes $ map (findRayObjIntersect ray) objs

ambient_occlusion :: [Object] -> Int -> Isect -> IO FColor
ambient_occlusion objs nao_samples isect = do
  randomRays <- sequence $ replicate nsample $ randomHemisphereRay p n
  let occludedNum = length [ray | ray <- randomRays, isHitOccluder objs ray]
  return $ vscale white $ 1.0 - occludedRatio occludedNum
    where
      eps = 0.0001
      n = isect_n isect
      p = isect_p isect `vadd` (n `vscale` eps)
      nsample = sq nao_samples
      occludedRatio occludedSampleNum =
          i2d occludedSampleNum / i2d nsample

screenRay :: Int -> Int -> Point -> Ray
screenRay w h (x, y) =
    Ray { ray_org = zerovec, ray_dir = vnormalize (Vec { x = px, y = py, z = -1 }) }
    where
      px = (i2d x - w_2) / w_2
      py = -(i2d y - h_2) / h_2
      w_2 = i2d w / 2.0
      h_2 = i2d h / 2.0

findNearestIsect :: [Object] -> Ray -> Maybe Isect
findNearestIsect objs ray =
    listToMaybe $ sort $ catMaybes $ map (findRayObjIntersect ray) objs

data Scene = Scene {
      scene_objs :: [Object]
    }

raytrace :: (Maybe Isect -> IO FColor) -> [Object] -> Ray -> IO FColor
raytrace fShading objs ray =
    fShading $ findNearestIsect objs ray

oversampling :: (Point -> IO FColor) -> Int -> IO FColor
oversampling fCalcCol nsubsamples =
  mapM fCalcCol subpixels >>= return . vaverage
    where
      subpixels = [(u, v) | v <- [0 .. nsubsamples-1], u <- [0 .. nsubsamples-1]]

renderSubsampledRayTracePixel :: (Ray -> IO FColor) -> Int -> Int -> Int -> Point -> IO FColor
renderSubsampledRayTracePixel fTrace w h nsubsamples (x, y) =
  oversampling calcCol nsubsamples
    where
      calcCol = fTrace . screenRay subedWidth subedHeight . subedPoint
      subedPoint (u, v) = (x * nsubsamples + u, y * nsubsamples + v)
      subedWidth = w * nsubsamples
      subedHeight = h * nsubsamples

renderScreen :: Int -> Int -> (Point -> IO col) -> IO [col]
renderScreen w h fRenderPixel =
  mapM fRenderPixel screenPixels
    where
      screenPixels = [(x, y) | y <- [0 .. h-1], x <- [0 .. w-1]]

renderSceneByAmbientOcclusion :: Scene -> Int -> Int -> Int -> Int -> IO [(Int, Int, Int)]
renderSceneByAmbientOcclusion scene w h nsubsamples nao_samples = do
  fimg <- renderScreen w h calcPixelColor
  return $ map fpcol2icol fimg
    where
      calcPixelColor = renderSubsampledRayTracePixel (raytrace shading objs) w h nsubsamples
      shading Nothing = return zerovec
      shading (Just isect) = ambient_occlusion objs nao_samples isect
      objs = scene_objs scene

saveppm :: String -> Int -> Int -> [(Int, Int, Int)] -> IO ()
saveppm fname w h img =
    withBinaryFile fname WriteMode $ \fp -> do
      hPutStrLn fp "P6"
      hPutStrLn fp $ show w ++ " " ++ show h
      hPutStrLn fp "255"
      B.hPut fp $ B.pack $ map toEnum $ concatMap (\(r,g,b) -> [r,g,b]) img

init_scene = Scene {
               scene_objs = [
                ObjSphere (Sphere { sphere_center = Vec { x = -2.0, y = 0.0, z = -3.5 }, sphere_radius = 0.5 }),
                ObjSphere (Sphere { sphere_center = Vec { x = -0.5, y = 0.0, z = -3.0 }, sphere_radius = 0.5 }),
                ObjSphere (Sphere { sphere_center = Vec { x =  1.0, y = 0.0, z = -2.2 }, sphere_radius = 0.5 }),
                ObjPlane  (Plane  { plane_p = Vec { x = 0.0, y = -0.5, z = 0.0 }, plane_n = Vec { x = 0.0, y = 1.0, z = 0.0 } })
               ]
             }

getParam idx defaultVal args
    | length args > idx  = args !! idx
    | otherwise          = defaultVal

main = do
  args <- getArgs
  let width  = read $ getParam 0 "256" args
  let height = read $ getParam 1 "256" args
  let nsubsamples = read $ getParam 2 "2" args
  let nao_samples = read $ getParam 3 "8" args

  img <- renderSceneByAmbientOcclusion init_scene width height nsubsamples nao_samples
  saveppm "ao.ppm" width height img

Three implementation models for scheme

2008-05-10T08:13:00.001+09:00

I'm reading "Three implementation models for scheme" these days. It describe how to implement scheme compiler and virtual machine. It is very good manual to novice scheme implementor.
Now I'm trying to implement stack-based model. I couldn't really understand very well, at first read. Again, I'm reading chapter 4, with implementing step by step.

Nicovideo

2008-03-09T20:49:00.002+09:00

I enjoy this movie.
【ニコニコ動画】ニコニコ動画ランキング in YouTube　25-11
How japanese anime, game, mad movie loved in the world!

Time Runs Away

2007-11-06T09:10:00.000+09:00

Oh! It's already November! I can't believe it! I work hard every day, and time runs away so fast.

Today I cook pasta even in the morning. Because shelf life of foods in my refrigerator is nearly dead line. Today's material is garlic chives, moyashi, and default materials, such as garlic, capsicum annuum. No meet, Oh! what a vegetarian I am!
Too many moyashi...? I don't care!

Complete! It's good taste. To human being, only salt and oil, it's can almost eat.

Too Hot...

2007-08-12T14:17:00.000+09:00

It is too hot these days. You know, when we see Cumulonimbus cloud, we feel summer.
Because of this hot temperature, we can't stop using air conditioner. We can't think nothing without comfotable temperature using it. But it is bad spiral. We use it, so the Earth heat. Then we use it more and more.

FERMAT'S LAST THEOREM

2007-08-09T07:57:00.000+09:00

I read a book, "FERMAT'S LAST THEOREM" by Simon Singh. It was very exciting. I didn't know, mathematics world has this exciting adventure in recent years!
I think Simon Singh is very good storyteller. He tells essence of story. you don't need familiar with mathematics.

Video:

Nuka-Duke

2007-08-08T08:01:00.000+09:00

I bought instant "Nuka-Duke kit" (Nuka-Duke is similar to pickled cucumber) in super-market. Usually, Nuka-Doko need maintenance per day, and can use many times. But this kit don't need maintenance, and can use only about ten times.

Nuka-Doko is little smelly. Oh, what strange food!

Squid Ink Spaghetti

2007-05-26T10:33:00.000+09:00

I used retort "squid sumi & Pomodoro" source (Kewpie). It's easy and delicious.

Revenge of pasta

2007-05-06T16:05:00.000+09:00

I failed to cook spaghetti in previous time. I think, it failed because of do not use salt and olive oil for boil pasta. I revenge by using them, and bell pepper, mushroom, garlic and chili pepper.

Complete! I use basilico paste on the last. It is convenient, and good taste.

I enjoy cooking these days. There are some reason to recommend cooking for yourself. First reason, It's just fun. I usually work by using computer. It is very logical process and any error were not acceptable. Other hand, cooking is very flexible, any material and procedure is responsible on your idea. It's very fun.

Second reason, it makes conversation. Every one eat food, therefore become common subject.

Third reason, it is reasonable price compare to eat in restaurant.

Cycling

2007-05-04T15:32:00.000+09:00

This week, we have a lot of holiday in Japan, we call this "Golden Week". I went to trip with my friend by bicycle. Along to Arakawa-River, we went down to the sea. It was very open load, and I got relax feeling. Over 20km, we finally reached at the Tokyo-sea. Yeah, we did it!

Then, we forward to Tsukiji, Japanese famous fish market. There were too many crowd in nallow load.

We went to Conveyor-belt sushi bar, but because of lot of people, we had to wait in line about 30 minutes. But indeed near the sea, fish is delicious. we satisfied.

Ahh, I was very tired. But it was very good trip. I refreshed by move body.

Spaghetti

2007-04-21T20:57:00.000+09:00

Today I'm gonna cook spaghetti. This is the first time I cook spaghetti. I only have a little pan. Can I make good?
Today's ingredient what I use are pasta 200g, eggplant, carrot, and seasoning (peperonteno).

Boiling pasta... Simple, but therefore difficult to make good one.

Complete! It looks not so good. And taste too. But I can eat because I made it. Next time I will make more good one.

By the way, a can in picture is "YEBISU THE HOP". "Yebisu" is famous beer bland in Japan. Expensive (about 300 yen), but delicious, deep taste. "THE HOP" is more cheaper bland, using hop. I think Yebisu do not need to make this cheaper bland. Yebisu must be yearning bland.

Seminar

2007-04-14T13:56:00.000+09:00

Yesterday, I went to the university of Tokyo to listen a seminar. The seminar's speaker was Yuki Mori. She research about computer aided stuffed animal making tool. She made software, "Pillow" and "Plushie". It was very exciting seminar.

She is going to talk on next siggraph. Amazing!

Cherry blossoms!

2007-03-30T10:51:00.000+09:00

It is very fine day. I can walk around only wearing T-shirt. Cherry blossoms blooming in a park. They are beautiful! My heart got excite!

Chimpan News Channel

2007-03-28T09:23:00.000+09:00

Do you know "Chimpan News Channel"? It is japanese TV program, host is cute chimpanzee, invite japanese actor or actress, and talk about human and animals. 50% joke, 50% sirius or good story.

This time, the host chimpanzee present some kind of animals in a zoo. The lesser panda and he are very friendly. It looks very happy. Other film search from youtube. Please watch them!

And I find a interesting blog: TV in Japan ≫ This is what TV is like. In Japan.

STARBUCKS

2007-03-24T10:12:00.000+09:00

I like Starbucks. I love hot "Caramel Macchiato", what is tasty flavor (images). But it is too expensive! Last november, Starbucks make all menu's price up about 20 to 40 yen (japanese news). Now, Caramel Macchiato is 360 yen. NO WAY!! I can't drink.

Cooking curry

2007-03-19T06:48:00.000+09:00

Today I cook curry. In Japan, curry is a most famous food. Everybody knows it, and love to eat it. I make normal, traditional curry. Carrot, potato, onion. And meet today I use is pork with spareribs.

Now I am cooking... It look tasty, isn't it?

Is curry famous in your country? What kind of curry do you eat? Please tell me!

Bicycle

2007-03-15T06:35:00.000+09:00

I bought a bicycle. And I go to office by this bicycle these days. It's about 30 minitus. This is very good exercise for me.

Go to Kyoto

2007-03-14T11:02:00.000+09:00

Today I went to Kyoto on bullet train. Before I went, at Tokyo statin, I have a time, I entered a coffee shop. Very Surprised me, this cheap cup of blend coffee is 300 yen! And taste too bad. No way!!

In bullet train, there is a snow outside. There are very different weather in japan at same season.

Futsal

2007-03-01T23:54:00.000+09:00

Today, I play futsal. While 20:00 to 22:00, about 15 people, everyone are working on different company. But we enjoy playing futsal together.
Futsal is very hard sports. Offence and diffence switch very quickly, dash and stop, turn cource, kick the ball, and so on.
It's hard to play, but because of it, we addict to it.

Talk of Patent

2007-02-28T21:38:00.000+09:00

Today I talk patent attorneies to some idea that I think to become patent. But again, in my fault, I can't speak the idea logically. I don't know patent law well. They said, the idea what I talk is very cheap work optimization. There is no special idea or advantage. I depressed much.
I reconsider my idea, and I talk to them again.

Presentation

2007-02-27T20:43:00.000+09:00

Today, I have a presentaion in my office. It's about work flow presentation. But I couldn't do good presentation. I mumbled, and I couldn't talk any word. My boss took word, and helped me. I have to practice presentation skill, otherwise I can't be good business person.

By the way, they said that tool must be easier than Macromedia Flash or Director. What a lazy people! I can't say any word. But customer is always selfish, no no, customer have many probrem, and they need own solution. We must respond to those demand.

A Dog of Flanders

2007-02-23T22:16:00.000+09:00

I watch DVD of "A Dog of Flanders" these days. It's played on TV in japan at 1975, one of the series of "World Masterpiece Theater". And until today, it's very famous story and it's loved almost every people in japan.

It's very sad story. It's original story is written in 1872. Nello who is the main character in the story is very poor. He can't go to school, and he work with his grandfather. In today, we can go to school usually. We are very fortunate.

YouTube: The Dog of Flanders Opening (JPN)

How did you like it?

My room

2007-02-19T22:00:00.000+09:00

I live in Tokyo, Japan. And this is my room. I live here alone. This type of apartment is called "one room manshion" in japan. But in fact, it's just a small apartment.
I have a notebook PC. I use this to browse Internet mainly.
This is a happy life.

Hello

2007-02-19T00:36:00.000+09:00

I am mokehehe. My english is very poor, but I study english and start writing blog in english. Please help and comment me. Thank you!