shine-examples (empty) → 0.1
raw patch · 11 files changed
+575/−0 lines, 11 filesdep +basedep +containersdep +ghcjs-dom
Dependencies added: base, containers, ghcjs-dom, keycode, random, shine
Files
- README.md +32/−0
- animated-shapes/Main.hs +50/−0
- mountaincar/Game.hs +30/−0
- mountaincar/Main.hs +86/−0
- mountaincar/MountainCar.hs +57/−0
- mountaincar/Point.hs +23/−0
- shine-examples.cabal +74/−0
- simple-interaction/Main.hs +30/−0
- spaceinvaders/Game.hs +125/−0
- spaceinvaders/Main.hs +46/−0
- spaceinvaders/Point.hs +22/−0
+ README.md view
@@ -0,0 +1,32 @@+# shine-examples++Examples for the `shine` library.++## Compiling++You need [ghcjs](https://github.com/ghcjs/ghcjs)++A great way of building ghcjs packages is to use the+[reflex platform](https://github.com/reflex-frp/reflex-platform)++## Contents++### animated-shapes++A lot of different shapes, some of them changing color, size and other properties with time.++Note: it will not work without manually copying `image.png` next to the `index.html` file.+See the "handling assets" section in the shine README for more info.++### simple-interaction++An extremely simple user interaction: a black square appears on left mouse down and disappears on mouse up.++### mountaincar++This is a human-controlled version of the [Mountain car problem](https://en.wikipedia.org/wiki/Mountain_car_problem) (a standard testing domain in Reinforcement learning). Use the left/right keys to control the car.++### spaceinvaders++This is a simplified version of the [Space Invaders](https://en.wikipedia.org/wiki/Space_Invaders) video game. Use the left/right keys to move the laser cannon and the space key to fire (or to restart the game).+
+ animated-shapes/Main.hs view
@@ -0,0 +1,50 @@+{-# LANGUAGE CPP #-}++import Graphics.Shine+import Graphics.Shine.Image+import Graphics.Shine.Picture++import GHCJS.DOM (currentDocumentUnchecked)++#if defined(ghcjs_HOST_OS)+run :: a -> a+run = id+#elif defined(MIN_VERSION_jsaddle_wkwebview)+import Language.Javascript.JSaddle.WKWebView (run)+#else+import Language.Javascript.JSaddle.WebKitGTK (run)+#endif++animation :: ImageData -> Double -> Picture+animation img x =+ Translate (75+x'/2) 15 (RectF (150+x') 30)+ <> Colored (Color 255 0 0 1.0) (Translate 15 (75+x'/2) $ Rect 30 (150+x'))+ <> Colored (Color 200 200 0 1.0) (Translate 660 30 $ RectF 120 60)+ <> Colored (Color 100 100 (floor x') 1.0) (Translate 600 340 $ RectF 120 240)+ <> Translate (150+x') 150 (circle 100)+ <> Translate 140 120 (circle (80+x'))+ <> Line 400 400 10 x'+ <> Colored (Color 255 0 0 1.0) (Translate 800 500 $ CircleF (x'/10))+ <> foldMap (Translate 300 300 . circle) [1,5..x']+ <> Translate 350 350 (Rotate (x'/200) $ RectF 150 30)+ <> Colored (Color 0 0 255 1) -- blue pentagon+ (Translate 200 500+ (Polygon [ (-110,-80)+ , (50,-120)+ , (140,20)+ , (30,140)+ , (-120,80)+ ]))+ <> Translate 100 500 (Image Original img)+ <> Translate 600 500 (Text "20px Sans" CenterAlign (Just 300) "The quick brown fox jumps over the lazy dog")+ where x' = sin (x*3) *100 +100++main :: IO ()+main = run $ do+ doc <- currentDocumentUnchecked+ ctx <- fixedSizeCanvas doc 800 600+ -- Handling assets is somewhat tricky.+ -- See the "handling assets" section in the shine README.+ img <- makeImage "./image.png"+ animate ctx 30 $ animation img+
+ mountaincar/Game.hs view
@@ -0,0 +1,30 @@+module Game where++import qualified MountainCar as MC++maxStep :: Int+maxStep = 200++data Game = Game+ { _observation :: MC.Observation+ , _lastAction :: MC.Action+ , _nwins :: Int+ , _episode :: Int+ , _step :: Int+ , _xis :: [Double]+ , _inputLeft :: Bool+ , _inputRight :: Bool }++createGame :: [Double] -> Game+createGame xis = Game (MC.initObs $ head xis) MC.ActionNothing 0 0 0 (tail xis) False False++step :: Game -> Game+step (Game obs _ nw eps ns xis il ir)+ | ns >= maxStep = Game (MC.initObs $ head xis) MC.ActionNothing nw (eps+1) 0 (tail xis) il ir+ | MC.goalObs obs = Game (MC.initObs $ head xis) MC.ActionNothing (nw+1) (eps+1) 0 (tail xis) il ir+ | otherwise = Game obs' action' nw eps (ns+1) xis il ir+ where action' | il && not ir = MC.ActionLeft+ | not il && ir = MC.ActionRight+ | otherwise = MC.ActionNothing+ obs' = MC.stepObs action' obs+
+ mountaincar/Main.hs view
@@ -0,0 +1,86 @@+import qualified Game as G+import qualified MountainCar as MC+import qualified Point as P++import qualified Graphics.Shine as S+import qualified Graphics.Shine.Input as S+import qualified Graphics.Shine.Picture as S+import qualified Web.KeyCode as W++import System.Random (newStdGen, randoms)+import GHCJS.DOM (currentDocumentUnchecked)++gameWidth :: Double+gameWidth = 800++gameHeight :: Double+gameHeight = 600++fps :: Double+fps = 30++minSpaceX :: Double+minSpaceX = MC.minPosition - 0.1++maxSpaceX :: Double+maxSpaceX = MC.maxPosition + 0.1++minSpaceY :: Double+minSpaceY = 0++maxSpaceY :: Double+maxSpaceY = 1.1++goalSpaceX :: Double+goalSpaceX = 0.5++goalSpaceY :: Double+goalSpaceY = MC.heightObs goalSpaceX++displayH :: G.Game -> S.Picture+displayH g = goalP <> carP <> episodeP <> nwinsP <> stepP <> actionP <> groundP+ where carP = mkCarP $ G._observation g+ episodeP = S.Translate 10 30 $ S.Text "20px Sans" S.LeftAlign Nothing $ "episode " ++ show (G._episode g)+ nwinsP = S.Translate 10 60 $ S.Text "20px Sans" S.LeftAlign Nothing $ "nwins " ++ show (G._nwins g)+ stepP = S.Translate 10 90 $ S.Text "20px Sans" S.LeftAlign Nothing $ "step " ++ show (G._step g) ++ " / " ++ show G.maxStep+ actionP = S.Translate 10 120 $ S.Text "20px Sans" S.LeftAlign Nothing $ "action " ++ show (G._lastAction g)++mkCarP :: MC.Observation -> S.Picture+mkCarP obs = S.Translate x y $ S.Colored (S.Color 0 0 255 1) $ S.CircleF 10+ where pos = MC._position obs+ (x,y) = spaceToScreen (pos, MC.heightObs pos)++goalP :: S.Picture+goalP = S.Translate x y $ S.Colored (S.Color 255 0 0 1) $ S.RectF 10 20+ where (x,y) = spaceToScreen (goalSpaceX, goalSpaceY)++groundP :: S.Picture+groundP = foldl (<>) S.Empty [S.Line x0 y0 x1 y1 | ((x0,y0), (x1,y1)) <- zip xys (tail xys)]+ where xys = [spaceToScreen (x, MC.heightObs x) + | x<-[MC.minPosition, MC.minPosition+0.05 .. MC.maxPosition]]++spaceToScreen :: P.Point -> P.Point+spaceToScreen (x, y) = (xScreen, yScreen)+ where xScreen = gameWidth * (x - minSpaceX) / (maxSpaceX - minSpaceX)+ yScreen = gameHeight * (1 - (y - minSpaceY) / (maxSpaceY - minSpaceY))++eventH :: S.Input -> G.Game -> G.Game +eventH (S.Keyboard W.ArrowLeft S.Down _) g = g { G._inputLeft = True }+eventH (S.Keyboard W.ArrowLeft S.Up _) g = g { G._inputLeft = False }+eventH (S.Keyboard W.ArrowRight S.Down _) g = g { G._inputRight = True }+eventH (S.Keyboard W.ArrowRight S.Up _) g = g { G._inputRight = False }+eventH _ g = g++idleH :: Double -> G.Game -> G.Game+idleH _ = G.step+-- The mountain car problem is generally defined using a fixed time step,+-- so we ignore the time delta and just compute the next step.++main :: IO ()+main = do+ myRands <- randoms <$> newStdGen+ doc <- currentDocumentUnchecked+ ctx <- S.fixedSizeCanvas doc (floor gameWidth) (floor gameHeight)+ let myModel = G.createGame myRands+ S.play ctx doc fps myModel displayH eventH idleH+
+ mountaincar/MountainCar.hs view
@@ -0,0 +1,57 @@+module MountainCar where++minPosition :: Double+minPosition = -1.2++maxPosition :: Double+maxPosition = 0.6++minInitPos :: Double+minInitPos = -0.6++maxInitPos :: Double+maxInitPos = -0.4++maxSpeed :: Double+maxSpeed = 0.07++goalPosition :: Double+goalPosition = 0.5++force :: Double+force = 0.001++gravity :: Double+gravity = 0.0025++data Action = ActionLeft | ActionNothing | ActionRight++instance Show Action where+ show ActionLeft = "<"+ show ActionRight = ">"+ show ActionNothing = "="++data Observation = Observation+ { _position :: Double+ , _velocity :: Double }++initObs :: Double -> Observation+initObs xi = Observation (minInitPos + xi * (maxInitPos - minInitPos)) 0++goalObs :: Observation -> Bool+goalObs obs = _position obs >= goalPosition++heightObs :: Double -> Double+heightObs x = 0.55 + 0.45 * sin (3 * x)++stepObs :: Action -> Observation -> Observation+stepObs action obs = obs { _position = p2, _velocity = v3 }+ where dv = case action of ActionNothing -> 0+ ActionLeft -> -force+ ActionRight -> force+ v1 = _velocity obs + dv - gravity * cos (3 * _position obs)+ v2 = max (-maxSpeed) $ min maxSpeed v1+ p1 = _position obs + v2+ p2 = max minPosition $ min maxPosition p1+ v3 = if p2 == minPosition && v2 < 0 then 0 else v2+
+ mountaincar/Point.hs view
@@ -0,0 +1,23 @@+module Point where++import qualified Prelude as P++type Point = (P.Double, P.Double)++(+) :: Point -> Point -> Point+(x0, y0) + (x1, y1) = (x0 P.+ x1, y0 P.+ y1)++(-) :: Point -> Point -> Point+(x0, y0) - (x1, y1) = (x0 P.- x1, y0 P.- y1)++(*) :: P.Double -> Point -> Point+k * (x, y) = (k P.* x, k P.* y)++negate :: Point -> Point+negate (x, y) = (P.negate x, P.negate y)++infixl 7 *+infixl 6 ++infixl 6 -++
+ shine-examples.cabal view
@@ -0,0 +1,74 @@+cabal-version: 2.2+name: shine-examples+version: 0.1+build-type: Simple+license: MIT+maintainer: Francesco Gazzetta <fgaz@fgaz.me>+homepage: https://github.com/fgaz/shine/tree/master/shine-examples+bug-reports: https://github.com/fgaz/shine/issues+synopsis: Examples for the shine package+description:+ This package contains some examples of use of the shine package,+ from animations to a simple game.+category: Web, Graphics, Javascript, Game+extra-source-files: README.md++common common-deps+ build-depends: base ^>= 4.11+ || ^>= 4.12+ , shine ^>= 0.2+ , ghcjs-dom ^>= 0.9++-- See the README for additional instructions on how to run animated-shapes+executable animated-shapes+ import: common-deps+ main-is: Main.hs+ hs-source-dirs: animated-shapes+ default-language: Haskell2010+ ghc-options: -threaded -Wall -Wno-missing-home-modules+ ghcjs-options: -dedupe+ cpp-options: -DGHCJS_BROWSER+ if !impl(ghcjs)+ buildable: False++executable simple-interaction+ import: common-deps+ main-is: Main.hs+ hs-source-dirs: simple-interaction+ default-language: Haskell2010+ ghc-options: -threaded -Wall -Wno-missing-home-modules+ ghcjs-options: -dedupe+ cpp-options: -DGHCJS_BROWSER+ if !impl(ghcjs)+ buildable: False++executable spaceinvaders+ import: common-deps+ main-is: Main.hs+ other-modules: Game Point+ hs-source-dirs: spaceinvaders+ default-language: Haskell2010+ ghc-options: -threaded -Wall -Wno-missing-home-modules+ ghcjs-options: -dedupe+ cpp-options: -DGHCJS_BROWSER+ build-depends: containers ^>= 0.6+ , keycode ^>= 0.2+ , random ^>= 1.1+ if !impl(ghcjs)+ buildable: False++executable mountaincar+ import: common-deps+ main-is: Main.hs+ other-modules: Game MountainCar Point+ hs-source-dirs: mountaincar+ default-language: Haskell2010+ ghc-options: -threaded -Wall -Wno-missing-home-modules+ ghcjs-options: -dedupe+ cpp-options: -DGHCJS_BROWSER+ build-depends: containers ^>= 0.6+ , keycode ^>= 0.2+ , random ^>= 1.1+ if !impl(ghcjs)+ buildable: False+
+ simple-interaction/Main.hs view
@@ -0,0 +1,30 @@+{-# LANGUAGE CPP #-}++import Graphics.Shine+import Graphics.Shine.Input+import Graphics.Shine.Picture++import GHCJS.DOM (currentDocumentUnchecked)++#if defined(ghcjs_HOST_OS)+run :: a -> a+run = id+#elif defined(MIN_VERSION_jsaddle_wkwebview)+import Language.Javascript.JSaddle.WKWebView (run)+#else+import Language.Javascript.JSaddle.WebKitGTK (run)+#endif++main :: IO ()+main = run $ do+ doc <- currentDocumentUnchecked+ ctx <- fixedSizeCanvas doc 800 600+ play ctx doc 30 initialState draw handleInput step+ where+ initialState = False+ draw False = Empty+ draw True = RectF 300 300+ handleInput (MouseBtn BtnLeft Down _) = const True+ handleInput (MouseBtn BtnLeft Up _) = const False+ handleInput _ = id+ step _ = id
+ spaceinvaders/Game.hs view
@@ -0,0 +1,125 @@+module Game where++import qualified Data.Map as M+import qualified Point as P++gameWidth, gameHeight :: Int+gameWidth = 800+gameHeight = 600++data Status = Running | Won | Lost deriving (Eq)++data Item = Item+ { _siz :: P.Point+ , _pos :: P.Point+ , _vel :: P.Point }++data Game = Game+ { _status :: Status+ , _inputLeft :: Bool+ , _inputRight :: Bool+ , _inputFire :: Bool+ , _rands :: [Double]+ , _firetime :: Double+ , _paddle :: Item+ , _bullets :: [Item]+ , _invaders :: [Item] }++createGame :: [Double] -> Game+createGame rands0 = Game Running False False False rands1 0 myPaddle [] myInvaders+ where myPaddle = Item (70, 20) (0, -250) (0, 0)+ ([mag, dir], rands1) = splitAt 2 rands0+ vx = (150 + 200 * mag) * (if dir < 0.5 then 1 else -1)+ myInvaders = [ Item (70, 20) + (fromIntegral x * 100, fromIntegral y * 50 + 150)+ (vx, 0)+ | x<-[-2..(2::Int)], y<-[0..(2::Int)] ]++updatePaddle :: Double -> Game -> Game+updatePaddle time g = firePaddleBullet time g1+ where dx = time * 200+ dl = if _inputLeft g then -dx else 0+ dr = if _inputRight g then dx else 0+ p0 = _paddle g+ (x0, y) = _pos p0+ x1 = max (-400) $ min 400 $ dl + dr + x0+ p1 = p0 { _pos = (x1, y) }+ g1 = g { _paddle = p1 }++firePaddleBullet :: Double -> Game -> Game+firePaddleBullet time g = if canFire then mFire else mNofire+ where canFire = _inputFire g && _firetime g > 0.9+ (x, y) = _pos $ _paddle g+ bullet = Item (3, 9) (x, y+20) (0, 200)+ mFire = g { _bullets = bullet : _bullets g, _firetime = 0 }+ mNofire = g { _firetime = time + _firetime g }++updateInvaders :: Double -> Game -> Game+updateInvaders time g = if null myInvaders then g else g3+ where myInvaders = _invaders g+ i1 = map (autoUpdateItem time) myInvaders+ xs = map (fst . _pos) myInvaders+ x1min = minimum xs+ x1max = maximum xs+ v@(vx, _) = _vel $ head myInvaders+ move v0 v1 i = i { _pos = _pos i P.+ time P.* v0, _vel = v1 }+ i2 | vx>0 && x1max>380 = map (move (380-x1max, 0) (P.negate v)) i1+ | vx<0 && x1min<(-380) = map (move (-380-x1min, 0) (P.negate v)) i1+ | otherwise = i1+ g2 = g { _invaders = i2 }+ g3 = fireInvadersBullets g2++fireInvadersBullets :: Game -> Game+fireInvadersBullets g = g { _bullets = _bullets g ++ bs, _rands = rands3 }+ where invadersPos = map _pos $ _invaders g+ fInsert pMap (x,y) = M.insertWith min x y pMap+ fighters0 = M.toList $ foldl fInsert M.empty invadersPos+ (rands0, rands1) = splitAt (length fighters0) (_rands g)+ (rands2, rands3) = splitAt (length fighters0) rands1+ difficulty = 0.9 + fromIntegral (length invadersPos) * (0.99 - 0.9) / 15+ fighters1 = [ (p, v) | (p, r, v) <- zip3 fighters0 rands0 rands2, r > difficulty ]+ createBullet ((x, y), v) = Item (3, 9) (x, y-20) (0, -(300-v*200))+ bs = map createBullet fighters1++autoUpdateItem :: Double -> Item -> Item+autoUpdateItem t i@(Item _ pos vel) = i { _pos = pos P.+ t P.* vel }++updateBullets :: Double -> Game -> Game+updateBullets time g = g { _bullets = b2 }+ where b1 = map (autoUpdateItem time) (_bullets g)+ b2 = filter (\b -> snd (_pos b) < 300 && snd (_pos b) > -300) b1++updateCollisions :: Game -> Game+updateCollisions g = g1 { _invaders = i1, _bullets = b2, _status = st }+ where (b1, i1) = runCollisions (_bullets g) (_invaders g)+ (b2, p2) = runCollisions b1 [_paddle g]+ st | null i1 = Won + | null p2 = Lost+ | otherwise = Running+ g1 = if st == Running then g + else g { _inputLeft = False, _inputRight = False, _inputFire = False }++testCollision :: Item -> Item -> Bool+testCollision (Item as ap _) (Item bs bp _) =+ ((bx0 < ax0 && ax0 < bx1) || (bx0 < ax1 && ax1 < bx1)) &&+ ((by0 < ay0 && ay0 < by1) || (by0 < ay1 && ay1 < by1))+ where (ax0, ay0) = ap P.- 0.5 P.* as+ (ax1, ay1) = ap P.+ 0.5 P.* as+ (bx0, by0) = bp P.- 0.5 P.* bs+ (bx1, by1) = bp P.+ 0.5 P.* bs++runCollisions :: [Item] -> [Item] -> ([Item], [Item])+runCollisions [] is = ([], is)+runCollisions (b:bs) is = (bs1++bs2, is2)+ where is1 = filter (not . testCollision b) is+ bs1 = [b | length is1 == length is]+ (bs2, is2) = runCollisions bs is1++step :: Double -> Game -> Game+step time g = if _status g == Running then mRunning else mEnd+ where mRunning = updatePaddle time+ $ updateInvaders time + $ updateBullets time+ $ updateCollisions g+ mEnd = if _inputFire g then createGame (_rands g) else g+
+ spaceinvaders/Main.hs view
@@ -0,0 +1,46 @@+import Game++import qualified Graphics.Shine as S+import qualified Graphics.Shine.Input as S+import qualified Graphics.Shine.Picture as S+import qualified Web.KeyCode as W++import System.Random (newStdGen, randoms)+import GHCJS.DOM (currentDocumentUnchecked)++displayH :: Game -> S.Picture+displayH g = S.Translate width2 height2 $ case _status g of+ Won -> S.Text "50px Sans" S.CenterAlign Nothing "YOU WIN!"+ Lost -> S.Text "50px Sans" S.CenterAlign Nothing "GAME OVER!"+ _ -> S.Rotate pi $ foldl (<>) paddle (bullets ++ invaders)+ where paddle = drawItem (S.Color 0 127 0 1) (_paddle g)+ bullets = map (drawItem (S.Color 0 0 255 1)) (_bullets g)+ invaders = map (drawItem (S.Color 255 0 0 1)) (_invaders g)+ width2 = fromIntegral $ div gameWidth 2+ height2 = fromIntegral $ div gameHeight 2++drawItem :: S.Color -> Item -> S.Picture+drawItem c it = S.Colored c $ S.Translate x y $ S.RectF sx sy+ where (x, y) = _pos it+ (sx, sy) = _siz it++eventH :: S.Input -> Game -> Game +eventH (S.Keyboard W.ArrowLeft S.Down _) g = g { _inputRight = True }+eventH (S.Keyboard W.ArrowLeft S.Up _) g = g { _inputRight = False }+eventH (S.Keyboard W.ArrowRight S.Down _) g = g { _inputLeft = True }+eventH (S.Keyboard W.ArrowRight S.Up _) g = g { _inputLeft = False }+eventH (S.Keyboard W.Space S.Down _) g = g { _inputFire = True }+eventH (S.Keyboard W.Space S.Up _) g = g { _inputFire = False }+eventH _ g = g++idleH :: Double -> Game -> Game +idleH = step++main :: IO ()+main = do+ myRands <- randoms <$> newStdGen+ doc <- currentDocumentUnchecked+ ctx <- S.fixedSizeCanvas doc 800 600+ let model0 = createGame myRands+ S.play ctx doc 30 model0 displayH eventH idleH+
+ spaceinvaders/Point.hs view
@@ -0,0 +1,22 @@+module Point where++import qualified Prelude as P++type Point = (P.Double, P.Double)++(+) :: Point -> Point -> Point+(x0, y0) + (x1, y1) = (x0 P.+ x1, y0 P.+ y1)++(-) :: Point -> Point -> Point+(x0, y0) - (x1, y1) = (x0 P.- x1, y0 P.- y1)++(*) :: P.Double -> Point -> Point+k * (x, y) = (k P.* x, k P.* y)++negate :: Point -> Point+negate (x, y) = (P.negate x, P.negate y)++infixl 7 *+infixl 6 ++infixl 6 -+