├── .gitignore
├── LICENSE
├── README.md
├── bower.json
├── dist
    └── app.js
├── index.html
├── package.json
├── src
    ├── Main.js
    └── Main.purs
└── test
    └── Main.purs


/.gitignore:
--------------------------------------------------------------------------------
1 | /bower_components/
2 | /node_modules/
3 | /.pulp-cache/
4 | /output/
5 | /.psci*
6 | /src/.webpack.js
7 | yarn.lock


--------------------------------------------------------------------------------
/LICENSE:
--------------------------------------------------------------------------------
 1 | The MIT License (MIT)
 2 | 
 3 | Copyright (c) 2016 Justin Woo
 4 | 
 5 | Permission is hereby granted, free of charge, to any person obtaining a copy
 6 | of this software and associated documentation files (the "Software"), to deal
 7 | in the Software without restriction, including without limitation the rights
 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
 9 | copies of the Software, and to permit persons to whom the Software is
10 | furnished to do so, subject to the following conditions:
11 | 
12 | The above copyright notice and this permission notice shall be included in all
13 | copies or substantial portions of the Software.
14 | 
15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
21 | SOFTWARE.
22 | 


--------------------------------------------------------------------------------
/README.md:
--------------------------------------------------------------------------------
1 | # purescript-cycle-etch-sketch
2 | 
3 | uses purescript-cycle-run and purescript-xstream to send data to a dom driver and get keyboard input directions and uses halogen to render an etch-sketch board
4 | 
5 | see demo [here](https://justinwoo.github.io/purescript-cycle-etch-sketch/)
6 | 


--------------------------------------------------------------------------------
/bower.json:
--------------------------------------------------------------------------------
 1 | {
 2 |   "name": "purescript-cycle-etch-sketch",
 3 |   "ignore": [
 4 |     "**/.*",
 5 |     "node_modules",
 6 |     "bower_components",
 7 |     "output"
 8 |   ],
 9 |   "dependencies": {
10 |     "purescript-xstream": "^0.9.1",
11 |     "purescript-cycle-run": "^0.8.0",
12 |     "purescript-eff": "^3.1.0",
13 |     "purescript-js-timers": "^3.0.0",
14 |     "purescript-sets": "^3.0.0",
15 |     "purescript-halogen": "^2.1.0",
16 |     "purescript-halogen-css": "^6.0.0"
17 |   },
18 |   "devDependencies": {}
19 | }
20 | 


--------------------------------------------------------------------------------
/index.html:
--------------------------------------------------------------------------------
1 | <!html>
2 | <script src="dist/app.js"></script>
3 | 


--------------------------------------------------------------------------------
/package.json:
--------------------------------------------------------------------------------
 1 | {
 2 |   "name": "purescript-cycle-etch-sketch",
 3 |   "version": "1.0.0",
 4 |   "description": "",
 5 |   "main": "index.js",
 6 |   "directories": {
 7 |     "test": "test"
 8 |   },
 9 |   "scripts": {
10 |     "build": "pulp browserify --to dist/app.js",
11 |     "test": "echo \"Error: no test specified\" && exit 1"
12 |   },
13 |   "author": "",
14 |   "license": "MIT",
15 |   "dependencies": {
16 |     "@cycle/run": "^3.1.0",
17 |     "xstream": "^10.9.0"
18 |   }
19 | }
20 | 


--------------------------------------------------------------------------------
/src/Main.js:
--------------------------------------------------------------------------------
1 | exports.onKeyboardDown = function (eff) {
2 |   return function () {
3 |     window.onkeydown = function (e) {
4 |       eff(e.keyCode)();
5 |     };
6 |   }
7 | };
8 | 


--------------------------------------------------------------------------------
/src/Main.purs:
--------------------------------------------------------------------------------
  1 | module Main where
  2 | 
  3 | import CSS (absolute, backgroundColor, black, border, grey, height, left, position, px, relative, solid, top, width)
  4 | import Control.Cycle (runRecord)
  5 | import Control.Monad.Aff (Aff, runAff)
  6 | import Control.Monad.Aff.AVar (AVAR)
  7 | import Control.Monad.Eff (Eff, kind Effect)
  8 | import Control.Monad.Eff.Class (liftEff)
  9 | import Control.Monad.Eff.Exception (EXCEPTION)
 10 | import Control.Monad.Eff.Ref (REF)
 11 | import Control.XStream (STREAM, Stream, addListener, fromCallback)
 12 | import DOM (DOM)
 13 | import Data.Array (fromFoldable)
 14 | import Data.Generic (gShow, class Generic)
 15 | import Data.Int (toNumber)
 16 | import Data.Maybe (Maybe(..))
 17 | import Data.Monoid (mempty)
 18 | import Data.Set (insert, Set)
 19 | import Halogen as H
 20 | import Halogen.Aff (runHalogenAff)
 21 | import Halogen.Aff.Util (awaitBody)
 22 | import Halogen.HTML as HH
 23 | import Halogen.HTML.CSS (style)
 24 | import Halogen.VDom.Driver (runUI)
 25 | import Prelude hiding (top)
 26 | 
 27 | data Direction
 28 |   = Left
 29 |   | Right
 30 |   | Up
 31 |   | Down
 32 | 
 33 | data Coords = Coords Int Int
 34 | derive instance genericCoords :: Generic Coords
 35 | instance showCoords :: Show Coords where
 36 |   show = gShow
 37 | derive instance eqCoords :: Eq Coords
 38 | derive instance ordCoords :: Ord Coords
 39 | 
 40 | data Query a
 41 |   = MoveCursor Direction a
 42 |   | ClearBoard a
 43 | 
 44 | type State =
 45 |   { cursor :: Coords
 46 |   , points :: Set Coords
 47 |   , width :: Int
 48 |   , height :: Int
 49 |   , increment :: Int
 50 |   }
 51 | 
 52 | initialState :: State
 53 | initialState =
 54 |   { cursor: Coords 0 0
 55 |   , points: mempty
 56 |   , width: 800
 57 |   , height: 600
 58 |   , increment: 10
 59 |   }
 60 | 
 61 | isInvalidPoint :: State -> Coords -> Boolean
 62 | isInvalidPoint state (Coords x y) =
 63 |   x < 0 || (state.increment * x) > (state.width - state.increment) ||
 64 |   y < 0 || (state.increment * y) > (state.height - state.increment)
 65 | 
 66 | ui :: forall e. H.Component HH.HTML Query Unit Void (Aff e)
 67 | ui = H.component {render, eval, initialState: const initialState, receiver: const Nothing}
 68 |   where
 69 |     px' = px <<< toNumber
 70 |     point inc color (Coords x y) = do
 71 |       let x' = inc * x
 72 |       let y' = inc * y
 73 |       HH.div
 74 |         [ style do
 75 |             position absolute
 76 |             left (px' x')
 77 |             top (px' y')
 78 |             width (px' inc)
 79 |             height (px' inc)
 80 |             backgroundColor color
 81 |         ]
 82 |         []
 83 | 
 84 |     render :: State -> H.ComponentHTML Query
 85 |     render s = do
 86 |       let point' = point s.increment
 87 |       HH.div_
 88 |         [ HH.h1_
 89 |           [ HH.text "Hello!!!" ]
 90 |         , HH.div
 91 |             [ style do
 92 |                 position relative
 93 |                 width (px' s.width)
 94 |                 height (px' s.height)
 95 |                 border solid (px' 1) black
 96 |             ] $
 97 |             (point' black <$> fromFoldable s.points) <>
 98 |             [point' grey s.cursor]
 99 |         ]
100 | 
101 |     eval :: Query ~> H.ComponentDSL State Query Void (Aff e)
102 |     eval (MoveCursor direction next) = do
103 |       H.modify moveCursor
104 |       pure next
105 |       where
106 |         shiftCursor (Coords x y) = case direction of
107 |           Up -> Coords x (y - 1)
108 |           Down -> Coords x (y + 1)
109 |           Left -> Coords (x - 1) y
110 |           Right -> Coords (x + 1) y
111 |         moveCursor :: State -> State
112 |         moveCursor s = do
113 |           let cursor' = shiftCursor s.cursor
114 |           if isInvalidPoint s cursor'
115 |             then s
116 |             else
117 |               s
118 |               { cursor = cursor'
119 |               , points = insert s.cursor s.points
120 |               }
121 |     eval (ClearBoard next) = do
122 |       H.modify $ \s -> s {points = mempty :: Set Coords}
123 |       pure next
124 | 
125 | yolo :: forall e a. Aff e a -> Eff e Unit
126 | yolo = void <$> runAff (const $ pure unit) (const $ pure unit)
127 | 
128 | sendDirections :: forall e o.
129 |   (H.HalogenIO Query o (Aff e)) ->
130 |   Direction ->
131 |   Eff e Unit
132 | sendDirections app x =
133 |   yolo $ app.query $ H.action $ MoveCursor x
134 | 
135 | dom :: forall e o.
136 |   (H.HalogenIO Query o (Aff (stream :: STREAM | e))) ->
137 |   Stream Direction ->
138 |   Eff
139 |     ( stream :: STREAM
140 |     | e
141 |     )
142 |     (Stream Unit)
143 | dom app s = do
144 |   addListener
145 |     { next: sendDirections app
146 |     , error: const $ pure unit
147 |     , complete: const $ pure unit
148 |     }
149 |     s
150 |   pure mempty
151 | 
152 | foreign import data KEYBOARD :: Effect
153 | foreign import onKeyboardDown :: forall e.
154 |   ( Int ->
155 |     Eff
156 |       ( kb :: KEYBOARD
157 |       , stream :: STREAM
158 |       | e
159 |       )
160 |       Unit
161 |   ) ->
162 |   Eff
163 |     ( kb :: KEYBOARD
164 |     , stream :: STREAM
165 |     | e
166 |     )
167 |     Unit
168 | 
169 | kb :: forall e.
170 |   Stream Unit ->
171 |   Eff
172 |     ( kb :: KEYBOARD
173 |     , stream :: STREAM
174 |     | e
175 |     )
176 |     (Stream Direction)
177 | kb _ = do
178 |   keys <- fromCallback onKeyboardDown
179 |   pure $ keyCodeToQuery =<< keys
180 |   where
181 |     keyCodeToQuery = case _ of
182 |       38 -> pure Up
183 |       40 -> pure Down
184 |       37 -> pure Left
185 |       39 -> pure Right
186 |       _ -> mempty
187 | 
188 | main :: forall e.
189 |   Eff
190 |     ( avar :: AVAR
191 |     , ref :: REF
192 |     , exception :: EXCEPTION
193 |     , dom :: DOM
194 |     , stream :: STREAM
195 |     | e
196 |     )
197 |     Unit
198 | main = runHalogenAff do
199 |   body <- awaitBody
200 |   app <- runUI ui unit body
201 |   let drivers = {dom: dom app, kb}
202 |   _ <- liftEff $ runRecord main' drivers
203 |   pure unit
204 |   where
205 |     main' :: { dom :: Stream Unit, kb :: Stream Direction } -> { dom :: Stream Direction, kb :: Stream Unit }
206 |     main' sources = {dom: sources.kb, kb: mempty}
207 | 


--------------------------------------------------------------------------------
/test/Main.purs:
--------------------------------------------------------------------------------
 1 | module Test.Main where
 2 | 
 3 | import Prelude
 4 | import Control.Monad.Eff (Eff)
 5 | import Control.Monad.Eff.Console (CONSOLE, log)
 6 | 
 7 | main :: forall e. Eff (console :: CONSOLE | e) Unit
 8 | main = do
 9 |   log "You should add some tests."
10 | 


--------------------------------------------------------------------------------