diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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). + diff --git a/animated-shapes/Main.hs b/animated-shapes/Main.hs new file mode 100644 --- /dev/null +++ b/animated-shapes/Main.hs @@ -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 + diff --git a/mountaincar/Game.hs b/mountaincar/Game.hs new file mode 100644 --- /dev/null +++ b/mountaincar/Game.hs @@ -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 + diff --git a/mountaincar/Main.hs b/mountaincar/Main.hs new file mode 100644 --- /dev/null +++ b/mountaincar/Main.hs @@ -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 + diff --git a/mountaincar/MountainCar.hs b/mountaincar/MountainCar.hs new file mode 100644 --- /dev/null +++ b/mountaincar/MountainCar.hs @@ -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 + diff --git a/mountaincar/Point.hs b/mountaincar/Point.hs new file mode 100644 --- /dev/null +++ b/mountaincar/Point.hs @@ -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 - + + diff --git a/shine-examples.cabal b/shine-examples.cabal new file mode 100644 --- /dev/null +++ b/shine-examples.cabal @@ -0,0 +1,74 @@ +cabal-version: 2.2 +name: shine-examples +version: 0.1 +build-type: Simple +license: MIT +maintainer: Francesco Gazzetta +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 + diff --git a/simple-interaction/Main.hs b/simple-interaction/Main.hs new file mode 100644 --- /dev/null +++ b/simple-interaction/Main.hs @@ -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 diff --git a/spaceinvaders/Game.hs b/spaceinvaders/Game.hs new file mode 100644 --- /dev/null +++ b/spaceinvaders/Game.hs @@ -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 + diff --git a/spaceinvaders/Main.hs b/spaceinvaders/Main.hs new file mode 100644 --- /dev/null +++ b/spaceinvaders/Main.hs @@ -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 + diff --git a/spaceinvaders/Point.hs b/spaceinvaders/Point.hs new file mode 100644 --- /dev/null +++ b/spaceinvaders/Point.hs @@ -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 - +