dalao-Painter in Haskell

dalao-Painter.hs

module Main where
import Graphics.UI.WX
import Graphics.UI.WXCore

-- constants: radius of the ball, and the maximal x and y coordinates
maxX, maxY :: Int
maxY = 600
maxX = 800
allowed_types = [("Bitmaps(*.bmp)",["*.bmp"]),("Any file(*.*)",["*.*"])]
save_type = [("Any file(*.*)",["*.*"])]
p_size = sz 700 510
f_size = sz 800 600
p_pos = pt 0 0
b_size = sz 25 25
b1_pos = pt 700 0
b2_pos = pt 730 0
b3_pos = pt 760 0
b4_pos = pt 700 30
b5_pos = pt 730 30
b6_pos = pt 760 30

b_rect_pos = pt 700 100
b_circle_pos = pt 730 100



--the main function
main :: IO ()
main = start ballsFrame

ballsFrame :: IO ()
ballsFrame
  = do
        --构造image缓冲区
       buf <- pixelBufferCreate (p_size)
       pixelBufferInit buf (rgb 255 255 255)
       img <- imageCreateFromPixelBuffer buf
       vimg <- varCreate img

       -- bitmaps can be downloaded from https://www.ihcblog.com/haskell_bitmaps.zip
       f <- frameFixed [text := "dalao-Painter", clientSize := f_size]
       b1 <- bitmapButton f [position := b1_pos, clientSize := b_size, picture := "bitmaps/blue.bmp"]
       b2 <- bitmapButton f [position := b2_pos, clientSize := b_size, picture := "bitmaps/red.bmp"]
       b3 <- bitmapButton f [position := b3_pos, clientSize := b_size, picture := "bitmaps/yellow.bmp"]
       b4 <- bitmapButton f [position := b4_pos, clientSize := b_size, picture := "bitmaps/green.bmp"]
       b5 <- bitmapButton f [position := b5_pos, clientSize := b_size, picture := "bitmaps/black.bmp"]
       b6 <- bitmapButton f [position := b6_pos, clientSize := b_size, picture := "bitmaps/white.bmp"]

       b_rect <- bitmapButton f [position := b_rect_pos, clientSize := b_size, picture := "bitmaps/rect.bmp"]
       b_circle <- bitmapButton f [position := b_circle_pos, clientSize := b_size, picture := "bitmaps/circle.bmp"]

       -- create menu
       file   <- menuPane      [text := "&File"]
       _open  <- menuItem file [text := "&Open\tCtrl+O", help := "Open an existing image", on command := readImg f vimg]
       _save  <- menuItem file [text := "&Save\tCtrl+S", help := "Save image to an file", on command := saveImg f vimg]
       _quit  <- menuQuit file [help := "Quit the dalao-Painter", on command := close f]

       -- create Help menu
       hlp    <- menuHelp      []
       about  <- menuAbout hlp [help := "About dalao-Painter"]

       -- create statusbar field
       status <- statusField   [text := "Welcome to dalao-Painter!"]


       p <- panel f [clientSize := p_size, position := p_pos]

       set p [on drag   := (addPoint vimg p)
             ,on paint  := onPaint vimg]

       set f [statusBar := [status],
              menuBar   := [file,hlp],
              on (menu about) := infoDialog f "About dalao-Painter" "This is dalao-Painter demo by Qin, Gu, Chi and Xu. for Haskell course."
             ]
   where
        -- 不用动这个函数，这个函数负责把一个var image画在窗口中
       onPaint::Var (Image a) -> DC b -> Rect -> IO ()
       onPaint img dc viewArea
            = do
                img_data <- varGet img
                drawImage dc img_data (pt 0 0) []

        -- 示例函数：点式笔刷 调用drawPointOnImage来实现 之后发送绘制事件给panel
       addPoint :: Var (Image a) -> Panel () -> Point -> IO ()
       addPoint img p pt
         = do drawPointOnImage img pt (rgb 255 0 0)
              repaint p

       drawPointOnImage::Var (Image a) -> Point -> Color -> IO ()
       drawPointOnImage img pt color
            = do
                img_data <- varGet img
                withPixelBuffer img_data (setPixels (getBrush pt 3) color)

       setPixels::[Point] -> Color -> PixelBuffer -> IO ()
       setPixels pts color buf
            = do mapM_ (setPixel buf color) pts 

       setPixel::PixelBuffer -> Color -> Point ->IO ()
       setPixel buf color pt
            = pixelBufferSetPixel buf pt color

       getBrush::Point -> Int -> [Point]
       getBrush p r = [(pt ((pointX p)+i) ((pointY p)+j)) | i <- [0..r], j <- [0..r]]

       readImg :: Frame a -> Var (Image ()) -> IO ()
       readImg f vImg = 
         do 
             mfilePath <- fileOpenDialog f True True "Open image" allowed_types "" ""
             case mfilePath of
                 Nothing -> do putStr "Nothing to read"
                 Just filePath -> do 
                     putStr filePath
                     putStr "Should be rewritten."

       saveImg :: Frame a -> Var (Image ()) -> IO ()
       saveImg f vImg = 
         do 
             mfilePath <- fileSaveDialog f True True "Save image" save_type "" "output.bmp"
             case mfilePath of
                 Nothing -> do putStr "Nothing to save"
                 Just filePath -> do 
                     putStr filePath
                     putStr "Should be rewritten."