Skip to content
This repository has been archived by the owner on Jun 18, 2023. It is now read-only.

Commit

Permalink
feat(geometry): Basic geometry shapes and stuff
Browse files Browse the repository at this point in the history
  • Loading branch information
prescientmoon committed Oct 10, 2020
1 parent f38bf7e commit 3e20ed9
Show file tree
Hide file tree
Showing 7 changed files with 463 additions and 0 deletions.
4 changes: 4 additions & 0 deletions package.json
Original file line number Diff line number Diff line change
Expand Up @@ -21,5 +21,9 @@
"live-server": "^1.2.1",
"nodemon": "^2.0.4",
"semantic-release": "^17.1.2"
},
"dependencies": {
"@thi.ng/geom": "^1.13.0",
"@thi.ng/hiccup-canvas": "^1.1.10"
}
}
1 change: 1 addition & 0 deletions packages.dhall
Original file line number Diff line number Diff line change
Expand Up @@ -30,5 +30,6 @@ let packages =
upstream
with lunarflow-utils = ./packages/utils/spago.dhall as Location
with lunarflow-core = ./packages/core/spago.dhall as Location
with lunarflow-geometry = ./packages/geometry/spago.dhall as Location

in packages overrides additions
23 changes: 23 additions & 0 deletions packages/geometry/spago.dhall
Original file line number Diff line number Diff line change
@@ -0,0 +1,23 @@
{ name = "lunarflow-geometry"
, dependencies =
[ "debug"
, "debugged"
, "generics-rep"
, "ordered-collections"
, "profunctor-lenses"
, "psci-support"
, "record"
, "strings"
, "transformers"
, "tuples"
, "typelevel-prelude"
, "undefined"
, "effect"
, "console"
, "canvas"
, "lunarflow-utils"
, "lunarflow-core"
]
, packages = ../../packages.dhall
, sources = [ "./src/**/*.purs" ]
}
19 changes: 19 additions & 0 deletions packages/geometry/src/Foreign.js
Original file line number Diff line number Diff line change
@@ -0,0 +1,19 @@
const geom = require("@thi.ng/geom");
const hiccupCanvas = require("@thi.ng/hiccup-canvas");

exports.mkRect = (attribs) => ({ x, y }) => (width) => (height) =>
geom.rect([x, y], [width, height], attribs);

exports.mkCircle = (attribs) => ({ x, y }) => (radius) =>
geom.circle([x, y], radius, attribs);

exports.mkPolygon = (attribs) => (points) =>
geom.polygon(
points.map(({ x, y }) => [x, y]),
attribs
);

exports.mkGroup = (attribs) => (shapes) => geom.group(attribs, shapes);

exports.renderGeometry = (shape) => (ctx) => () =>
hiccupCanvas.draw(ctx, shape);
31 changes: 31 additions & 0 deletions packages/geometry/src/Foreign.purs
Original file line number Diff line number Diff line change
@@ -0,0 +1,31 @@
module Lunarflow.Geometry.Foreign
( Geometry
, fromShape
, renderGeometry
) where

import Prelude
import Effect (Effect)
import Graphics.Canvas (Context2D)
import Lunarflow.Geometry.Types (CommonAttribs, PolygonAttribs, Position, Shape(..))

-- | @thi.ng/geom Geometry representation.
foreign import data Geometry :: Type

-- | Cast a purescript shape to a js geometry.
fromShape :: Shape -> Geometry
fromShape = case _ of
Rect attribs position width height -> mkRect attribs position width height
Circle attribs position radius -> mkCircle attribs position radius
Polygon attribs points -> mkPolygon attribs points
Group attribs shapes -> mkGroup attribs (fromShape <$> shapes)

foreign import mkRect :: { | CommonAttribs () } -> { | Position () } -> Int -> Int -> Geometry

foreign import mkCircle :: { | CommonAttribs () } -> { | Position () } -> Int -> Geometry

foreign import mkPolygon :: { | CommonAttribs () } -> PolygonAttribs -> Geometry

foreign import mkGroup :: { | CommonAttribs () } -> Array Geometry -> Geometry

foreign import renderGeometry :: Geometry -> Context2D -> Effect Unit
67 changes: 67 additions & 0 deletions packages/geometry/src/Types.purs
Original file line number Diff line number Diff line change
@@ -0,0 +1,67 @@
module Lunarflow.Geometry.Types where

import Prelude
import Data.Debug (class Debug, genericDebug)
import Data.Generic.Rep (class Generic)
import Lunarflow.Row (class PartialRow, withDefaults)
import Type.Row (type (+))

type CommonAttribs r
= ( fill :: String
, stroke :: String
| r
)

type Position r
= ( x :: Int, y :: Int
| r
)

type ShapeConstructor a
= forall r. PartialRow (CommonAttribs ()) r => Record r -> a

newtype PolygonAttribs
= PolygonAttribs (Array (Record (Position + ())))

derive instance genericPolygonAttribs :: Generic PolygonAttribs _

instance debugPolygonAttribs :: Debug PolygonAttribs where
debug = genericDebug

data Shape
= Rect { | CommonAttribs () } { | Position () } Int Int
| Polygon { | CommonAttribs () } PolygonAttribs
| Circle { | CommonAttribs () } { | Position () } Int
| Group { | CommonAttribs () } (Array Shape)

mergeAttribs :: { | CommonAttribs () } -> { | CommonAttribs () } -> { | CommonAttribs () }
mergeAttribs a b = { fill: b.fill, stroke: b.stroke }

instance shapeSemigroup :: Semigroup Shape where
append (Group attribs shapes) (Group attribs' shapes') = Group (mergeAttribs attribs attribs') (shapes <> shapes')
append (Group attribs shapes) shape = Group attribs (shapes <> [ shape ])
append shape other@(Group _ _) = append other shape
append a b = Group defaultAttribs [ a, b ]

instance monoidSemigroup :: Monoid Shape where
mempty = Group defaultAttribs []

derive instance genericShape :: Generic Shape _

instance debugSemigruoup :: Debug Shape where
debug a = genericDebug a

rect :: ShapeConstructor ({ | Position () } -> Int -> Int -> Shape)
rect attribs = Rect (withDefaults defaultAttribs attribs)

polygon :: ShapeConstructor (PolygonAttribs -> Shape)
polygon attribs = Polygon (withDefaults defaultAttribs attribs)

circle :: ShapeConstructor ({ | Position () } -> Int -> Shape)
circle attribs = Circle (withDefaults defaultAttribs attribs)

group :: ShapeConstructor (Array Shape -> Shape)
group attribs = Group (withDefaults defaultAttribs attribs)

defaultAttribs :: { | CommonAttribs () }
defaultAttribs = { fill: "blue", stroke: "black" }
Loading

0 comments on commit 3e20ed9

Please sign in to comment.