Skip to content

Instantly share code, notes, and snippets.

@jagajaga
Created September 26, 2015 21:58
Show Gist options
  • Save jagajaga/087e834d6ed06262d0f3 to your computer and use it in GitHub Desktop.
Save jagajaga/087e834d6ed06262d0f3 to your computer and use it in GitHub Desktop.
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE UnboxedTuples #-}
import Prelude (Bool (..), Double, Float, Int,
Monad (..), Show (..), String,
acos, asin, atan, atan2, cos,
error, fromIntegral, not, pi,
realToFrac, sin, sqrt,
undefined, (&&), (||))
import qualified Prelude as P
import Control.Monad.Trans (liftIO)
import Data.IORef
import qualified Data.Set as S
import Data.Time.Clock.POSIX
import qualified Graphics.Rendering.Cairo as C
import qualified Graphics.Rendering.Cairo.Matrix as M
import Graphics.UI.Gtk hiding (Arrow, drawPolygon,
fill, lineWidth)
import Graphics.UI.Gtk.Gdk.Events
import System.IO.Unsafe (unsafePerformIO)
-- Something scary
data Corner = TopLeft | TopCenter | TopRight
| MiddleLeft | MiddleCenter | MiddleRight
| BottomLeft | BottomCenter | BottomRight
deriving Show
cornerPos :: Corner -> Vector2 Double
cornerPos TopLeft = Vector2 0 0
cornerPos TopCenter = Vector2 (1/2) 0
cornerPos TopRight = Vector2 1 0
cornerPos MiddleLeft = Vector2 0 (1/2)
cornerPos MiddleCenter = Vector2 (1/2) (1/2)
cornerPos MiddleRight = Vector2 1 (1/2)
cornerPos BottomLeft = Vector2 0 1
cornerPos BottomCenter = Vector2 (1/2) 1
cornerPos BottomRight = Vector2 1 1
data Image = Image M.Matrix Pixbuf
{-# NOINLINE image #-}
image w h flip c x = unsafePerformIO $ do
i <- pixbufNewFromFile x
r <- pixbufScaleSimple i w h InterpHyper
return $ Image (M.Matrix 1 0 0 (if flip then -1 else 1) (negate a) (if flip then b else negate b)) r
where
(Vector2 a b) = vzip (*) (Vector2 (fromIntegral w) (fromIntegral h)) (cornerPos c)
putImage (Image m i) = do
C.save
C.transform m
setSourcePixbuf i 0 0
C.paint
C.restore
render :: (Show z) => Bool
-> Int -> Int -> Int -> z
-> (Double -> Double -> (String -> Bool) -> z -> z)
-> (Vector2 Double -> z -> C.Render ())
-> P.IO ()
render debug width height tick z stateFun renderFun = do
t0 <- getPOSIXTime
prevtime <- newIORef t0
state <- newIORef z
keys <- newIORef (S.empty :: S.Set String)
initGUI
window <- windowNew
drawingArea <- drawingAreaNew
set window [ containerChild := drawingArea ]
windowSetDefaultSize window width height
widgetModifyBg drawingArea StateNormal (Color 0xffffff 0xffffff 0xffffff)
onDestroy window mainQuit
onExpose drawingArea $ handleDraw drawingArea state
onKeyPress window $ handleKey t0 prevtime keys state
onKeyRelease window $ handleKey t0 prevtime keys state
timeoutAdd (updateState t0 prevtime keys state >> widgetQueueDraw drawingArea >> return True) tick
widgetShowAll window
mainGUI
where
updateState t0 prevtime keys state = do
t <- getPOSIXTime
tp <- readIORef prevtime
ks <- readIORef keys
cs <- readIORef state
if debug
then do
P.putStrLn "-- Debug"
P.print t
P.print ks
P.print cs
else return ()
writeIORef state $ stateFun (P.realToFrac $ t P.- t0) (P.realToFrac $ t P.- tp) (`S.member` ks) cs
writeIORef prevtime t
handleDraw drawingArea state _ = do
win <- widgetGetDrawWindow drawingArea
(w', h') <- widgetGetSize drawingArea
let w = realToFrac w'
h = realToFrac h'
cs <- readIORef state
renderWithDrawable win $ do
C.setMatrix $ M.Matrix 1 0 0 (-1) 0 h
renderFun (Vector2 w h) cs
return True
handleKey t0 prevtime keys state (Key rel _ _ mod _ _ _ val name char) = do
modifyIORef keys $ \ks ->
if rel
then S.delete name ks
else S.insert name ks
updateState t0 prevtime keys state
return True
-- Holes
data Hole = Hole
hole = error "hole"
-- Algebra
class Monoid a where
mzero :: a
mappend :: a -> a -> a
mconcat :: [ a ] -> a
mconcat = P.foldr mappend mzero
class Monoid a => Foldable f a where
fold :: f a -> a
instance Monoid a => Foldable [] a where
fold = P.foldr mappend mzero
-- Instances
newtype Any = Any { unAny :: Bool }
instance Monoid Any where
mzero = Any False
mappend (Any x) (Any y) = Any (x || y)
newtype All = All { unAll :: Bool }
instance Monoid All where
mzero = All True
mappend (All x) (All y) = All (x && y)
instance Monoid Float where
mzero = 0
mappend = (P.+)
instance Monoid Double where
mzero = 0
mappend = (P.+)
--
class Monoid a => Group a where
ginv :: a -> a
gsub :: a -> a -> a
gsub x y = mappend x (ginv y)
instance Group Float where
ginv = P.negate
gsub = (P.-)
instance Group Double where
ginv = P.negate
gsub = (P.-)
---
class Group a => Ring a where -- very Monoidy
rone :: a
rmult :: a -> a -> a
instance Ring Float where
rone = 1
rmult = (P.*)
instance Ring Double where
rone = 1
rmult = (P.*)
--
class Ring a => Field a where
recip :: a -> a
(/) :: a -> a -> a
(/) x y = rmult x (recip y)
(+) :: Monoid a => a -> a -> a
(+) = mappend
negate :: Group a => a -> a
negate = ginv
(-) :: Group a => a -> a -> a
(-) = gsub
(*) :: Ring a => a -> a -> a
(*) = rmult
instance Field Float where
recip = P.recip
(/) = (P./)
instance Field Double where
recip = P.recip
(/) = (P./)
-- Vector Spaces
class (Group v, Field s) => VectorSpace v s | v -> s where
(^*) :: s -> v -> v
(^/) :: v -> s -> v
(^/) v x = (^*) (recip x) v
--
class BasicVector v where
diagonal :: s -> v s
vmap :: (s -> s) -> v s -> v s
vzip :: (s -> s -> s) -> v s -> v s -> v s
vfold :: (s -> s -> s) -> v s -> s
instance (Monoid s, BasicVector v) => Monoid (v s) where
mzero = diagonal mzero
mappend = vzip mappend
instance (Group s, BasicVector v) => Group (v s) where
ginv = vmap ginv
gsub = vzip gsub
instance (Field s, BasicVector v) => VectorSpace (v s) s where
(^*) s = vmap (s *)
(^/) v s = vmap (/ s) v
--instance (Ring s, BasicVector v) => Ring (v s) where
-- rone = diagonal rone
-- rmult = vzip rmult
--
--instance (Field s, BasicVector v) => Field (v s) where
-- recip = vmap recip
-- (/) = vzip (/)
-- pointwise product
(.*) :: (Field s, BasicVector v) => v s -> v s -> v s
(.*) x y = vzip (*) x y
-- inner product
(**) :: (Field s, BasicVector v) => v s -> v s -> s
(**) x y = vfold (+) (x .* y)
norm :: (Field s, BasicVector v, P.Floating s) => v s -> s
norm v = sqrt $ v ** v
normalize v = v ^/ (norm v)
-- Matices
type Matrix = M.Matrix
instance Monoid Matrix where
mzero = M.Matrix 0 0 0 0 0 0
mappend = (P.+)
instance Group Matrix where
ginv = negate
instance VectorSpace Matrix Double where
(^*) = M.scalarMultiply
instance Ring Matrix where
rone = M.identity
rmult = (P.*)
instance Field Matrix where
recip = M.invert
rotationMatrix a = M.Matrix (cos a) (negate $ sin a) (sin a) (cos a) 0 0
-- 2D Vectors
data Vector2 a = Vector2 !a !a
deriving Show
uncurryVector2 f (Vector2 x y) = f x y
instance BasicVector Vector2 where
diagonal s = Vector2 s s
vmap f (Vector2 x y) = Vector2 (f x) (f y)
vzip f (Vector2 x y) (Vector2 x' y') = Vector2 (f x x') (f y y')
vfold o (Vector2 x y) = x `o` y
angleVector2 (Vector2 x y) = atan2 y x
angleBetweenVector2 p t = angleVector2 p - angleVector2 t
transformVector2 m (Vector2 x y) = Vector2 a b where
(a, b) = M.transformPoint m (x, y)
-- 3D Vectors
data Vector3 a = Vector3 !a !a !a
deriving Show
instance BasicVector Vector3 where
diagonal s = Vector3 s s s
vmap f (Vector3 x y z) = Vector3 (f x) (f y) (f z)
vzip f (Vector3 x y z) (Vector3 x' y' z') = Vector3 (f x x') (f y y') (f z z')
vfold o (Vector3 x y z) = x `o` y `o` z
--
data Color3 a = Color3 !a !a !a
deriving Show
instance BasicVector Color3 where
diagonal s = Color3 s s s
vmap f (Color3 x y z) = Color3 (f x) (f y) (f z)
vzip f (Color3 x y z) (Color3 x' y' z') = Color3 (f x x') (f y y') (f z z')
vfold o (Color3 x y z) = x `o` y `o` z
--
data Color4 a = Color4 !a !a !a !a
deriving Show
instance BasicVector Color4 where
diagonal s = Color4 s s s s
vmap f (Color4 x y z a) = Color4 (f x) (f y) (f z) (f a)
vzip f (Color4 x y z a) (Color4 x' y' z' a') = Color4 (f x x') (f y y') (f z z') (f a a')
vfold o (Color4 x y z a) = x `o` y `o` z `o` a
-- Function
infixr 0 $
($) :: (a -> b) -> a -> b
($) f x = f x
-- Category and Arrow
class Category cat where
id :: cat a a
(.) :: cat b c -> cat a b -> cat a c
(>>>) :: Category cat => cat a b -> cat b c -> cat a c
(>>>) = P.flip (.)
instance Category (->) where
id x = x
(.) f g x = f (g x)
class Category cat => Arrow cat where
arr :: (a -> b) -> cat a b
first :: cat a b -> cat (a, c) (b, c)
second :: cat a b -> cat (c, a) (c, b)
(***) :: cat a b -> cat a' b' -> cat (a, a') (b, b')
(***) f g = first f >>> second g
(&&&) :: cat a b -> cat a b' -> cat a (b, b')
(&&&) f g = arr (\x -> (x, x)) >>> (f *** g)
instance Arrow (->) where
arr = id
first f (x, y) = (f x, y)
second f (x, y) = (x, f y)
(***) f g (x, y) = (f x, g y)
(&&&) f g x = (f x, g x)
-- Functor
class Functor f where
fmap :: (a -> b) -> f a -> f b
instance Functor [] where
fmap = P.map
instance Functor ((->) c) where
fmap f g c = f (g c)
--class Applicative f where
-- pure :: a -> f a
-- (<$>) :: f (a -> b) -> f a -> f b
--instance Functor ((←) c) where
-- fmap f g c = hole
--
infixr 4 +
infixr 4 -
infixr 5 ^*
infixr 5 ^/
infixr 5 *
infixr 5 /
-- drawing
rgb (Color3 r g b) = C.setSourceRGB r g b
rgba (Color4 r g b a) = C.setSourceRGBA r g b a
translate = uncurryVector2 C.translate
rotate = C.rotate
lineWidth = C.setLineWidth
scale = uncurryVector2 C.scale
moveTo = uncurryVector2 C.moveTo
lineTo = uncurryVector2 C.lineTo
drawPolygon xs = drawOpenPolygon xs >> C.closePath
drawOpenPolygon [] = return ()
drawOpenPolygon (x:xs) = C.newPath >> moveTo x >> P.mapM_ lineTo xs
fill f = f >> C.fill
stroke f = f >> C.stroke
fillPolygon = fill . drawPolygon
strokePolygon = stroke . drawPolygon
strokeLine = stroke . drawOpenPolygon
strokeWidthLine x p = lineWidth x >> strokeLine p
--
data RocketState = RocketState
{ t :: Double
, p :: Vector2 Double
, v :: Vector2 Double
, o :: Vector2 Double
, a :: Vector2 Double
} deriving Show
startState = RocketState
{ t = 0
, p = Vector2 0 0
, v = Vector2 0 0
, o = Vector2 0 1
, a = Vector2 0 0
}
throttle k s = s { a = 100 ^* c ^* (o s)
, o = transformVector2 (rotationMatrix $ 0.01 * alpha) (o s) } where
c = key "Down" (- 1) 0 + key "Up" 1 0
alpha = key "Left" (- 1) 0 + key "Right" 1 0
key s yes no = if k s then yes else no
physics dt s = s { p = p s + dt ^* v s
, v = v s + dt ^* a s }
friction dt s = s { v = v s - dt ^* v s ^/ 2 }
stateFun t dt k = friction dt . physics dt . throttle k . (\x -> x { t = t })
wbushes w f 0 _ _ = []
wbushes w f n p seg = Vector2 p nextp
: wbushes (w ^/ 1.1) f (n P.- 1) nextp (nextseg f)
P.++ wbushes (w ^/ 1.1) f (n P.- 1) nextp (nextseg (negate . f))
where
nextp = p + seg + w
nextseg f = transformVector2 (rotationMatrix $ f n) seg
renderFun window (RocketState {..}) = do
translate $ (Vector2 (1/2) (1/2)) .* window
rgb (Color3 0 0 0)
C.rectangle (-5) (-5) 10 10
C.fill
P.mapM_ (\(Vector2 f t) -> strokeWidthLine 1 [f, t]) $ wbushes (Vector2 (2 * sin t) 0) ((* 0.05) . fromIntegral) 8 (Vector2 0 0) (Vector2 0 20)
translate p
C.rotate $ angleBetweenVector2 o (Vector2 0 1)
putImage rocket
where
rocket = image 50 50 True MiddleCenter "rocket.png"
main = render False 500 500 16 startState stateFun renderFun
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment