~alcinnz/Mondrian

ref: 05c8b4fe321de441c69e39e7e6350feb556157e6 Mondrian/app/Main.hs -rw-r--r-- 2.3 KiB
05c8b4fe — Adrian Cochrane Build texturing infrastructure. 1 year, 4 months ago
                                                                                
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
{-# LANGUAGE OverloadedStrings #-}
module Main where

import Graphics.Rendering.Rect
import Stylist.Parse (parseProperties')
import Stylist (PropertyParser(..))
import Data.Text (pack, unpack)
import Data.CSS.Syntax.Tokens (tokenize, serialize)

import SDL hiding (trace)
import Graphics.GL.Core32
import System.Environment (getArgs)
import Linear.Projection (ortho)

import Data.Function (fix)
import Control.Monad (unless)
import Control.Monad.IO.Class (MonadIO (..))

import Debug.Trace (trace) -- To warn about invalid args

parseStyle syn
    | (ret, []) <- parseProperties' toks = apply ret
    | (ret, tail) <- parseProperties' toks =
        trace ("Extraneous chars: " ++ unpack (serialize tail)) $ apply ret
  where
    toks = tokenize $ pack syn
    apply ((key, val):props)
        | Just self' <- longhand self self key val = self'
        | props'@(_:_) <- shorthand self key val = apply (props' ++ props)
        | otherwise = trace ("Unsupported property " ++ unpack key) self
      where self = apply props
    apply [] = temp

orthoProjection (V2 ww wh) =
  let (hw,hh) = (fromIntegral ww, fromIntegral wh)
  in ortho 0 hw hh 0 0 1

main :: IO ()
main = do
    SDL.initializeAll
    args <- getArgs
    let style :: RectStyle
        style = case args of
            [] -> trace "Using blank styles, should see blank screen!" temp
            [arg] -> parseStyle arg
            (arg:_) -> trace "Extraneous commandline args!" $ parseStyle arg

    let openGL = defaultOpenGL { glProfile = Core Debug 3 3 }
        wcfg = defaultWindow {
            windowInitialSize = V2 640 480,
            windowGraphicsContext = OpenGLContext openGL,
            windowResizable = True
          }
    w <- createWindow "Mondrian" wcfg
    _ <- glCreateContext w

    render <- renderRects
    fix $ \loop -> do
        events <- fmap eventPayload <$> pollEvents
        liftIO $ glClearColor 1 1 1 1
        liftIO $ glClear GL_COLOR_BUFFER_BIT

        sz@(V2 dw dh) <- liftIO $ glGetDrawableSize w
        liftIO $ glViewport 0 0 (fromIntegral dw) (fromIntegral dh)

        let rect = Rect 0 0 (fromIntegral dw) (fromIntegral dh)
            rects = Rects (shrink1 rect 15) (shrink1 rect 10) (shrink1 rect 5) rect

        render style rects $ orthoProjection sz

        liftIO $ glSwapWindow w
        unless (QuitEvent `elem` events) loop