This repository has been archived by the owner on Jun 18, 2023. It is now read-only.
-
Notifications
You must be signed in to change notification settings - Fork 0
Commit
This commit does not belong to any branch on this repository, and may belong to a fork outside of the repository.
feat(geometry): Basic geometry shapes and stuff
- Loading branch information
1 parent
f38bf7e
commit 3e20ed9
Showing
7 changed files
with
463 additions
and
0 deletions.
There are no files selected for viewing
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
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" ] | ||
} |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
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); |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
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 |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
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" } |
Oops, something went wrong.