packages feed

geomancy-layout (empty) → 0.1

raw patch · 8 files changed

+684/−0 lines, 8 filesdep +basedep +geomancydep +gl-blocksetup-changed

Dependencies added: base, geomancy, gl-block

Files

+ CHANGELOG.md view
@@ -0,0 +1,5 @@+## 0.1++Initial import.++Extracted from `keid-core`.
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright IC Rainbow (c) 2023++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of IC Rainbow nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,9 @@+## geomancy-layout++Layout primitives using [geomancy] vectors.++* `Geomancy.Layout` - box cutting and stacking.+* `Geomancy.Layout.Box` - size/position and top/right/bottom/left boxes and manipulation.+* `Geomancy.Layout.Alignment` - distribute size leftovers proportionally.++[geomancy]: https://hackage.haskell.org/package/geomancy
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ geomancy-layout.cabal view
@@ -0,0 +1,50 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.35.2.+--+-- see: https://github.com/sol/hpack++name:           geomancy-layout+version:        0.1+synopsis:       Geometry and matrix manipulation+description:    Layout primitives and algorithms for geomancy data.+category:       Graphics+author:         IC Rainbow+maintainer:     aenor.realm@gmail.com+copyright:      2023 IC Rainbow+license:        BSD3+license-file:   LICENSE+build-type:     Simple+extra-source-files:+    README.md+    CHANGELOG.md++source-repository head+  type: git+  location: https://gitlab.com/dpwiz/geomancy-layout++library+  exposed-modules:+      Geomancy.Layout+      Geomancy.Layout.Alignment+      Geomancy.Layout.Box+  other-modules:+      Paths_geomancy_layout+  hs-source-dirs:+      src+  default-extensions:+      BlockArguments+      DeriveAnyClass+      DerivingStrategies+      DerivingVia+      ImportQualifiedPost+      LambdaCase+      OverloadedRecordDot+      PatternSynonyms+      RecordWildCards+  ghc-options: -Wall+  build-depends:+      base >=4.7 && <5+    , geomancy >=0.2.6 && <1+    , gl-block >=1.0 && <2+  default-language: GHC2021
+ src/Geomancy/Layout.hs view
@@ -0,0 +1,221 @@+module Geomancy.Layout where++import Geomancy++import Geomancy.Layout.Alignment (Alignment, Origin)+import Geomancy.Layout.Alignment qualified as Alignment+import Geomancy.Layout.Box (Box(..), TRBL(..))+import Geomancy.Layout.Box qualified as Box+-- import Debug.Trace++type Offset = Float++horizontal+  :: Either Offset Origin+  -> Box+  -> (Box, Box)+horizontal = \case+  Left width ->+    if width >= 0 then+      cutLeft width+    else+      cutRight (-width)+  Right origin ->+    if origin >= 0 then+      splitLeft origin+    else+      splitRight (-origin)++vertical+  :: Either Offset Origin+  -> Box+  -> (Box, Box)+vertical = \case+  Left height ->+    if height >= 0 then+      cutTop height+    else+      cutBottom (-height)+  Right origin ->+    if origin >= 0 then+      splitTop origin+    else+      splitBottom (-origin)++cutLeft :: Offset -> Box -> (Box, Box)+cutLeft width parent =+  Box.withTRBL parent \t r b l ->+    let+      edge = l + width+    in+      ( Box.fromTRBL t edge b l+      , Box.fromTRBL t r b edge+      )++cutRight :: Offset -> Box -> (Box, Box)+cutRight width parent =+  Box.withTRBL parent \t r b l ->+    let+      edge = r - width+    in+      ( Box.fromTRBL t edge b l+      , Box.fromTRBL t r b edge+      )++cutTop :: Offset -> Box -> (Box, Box)+cutTop height parent =+  Box.withTRBL parent \t r b l ->+    let+      edge = t + height+    in+      ( Box.fromTRBL t r edge l+      , Box.fromTRBL edge r b l+      )++cutBottom :: Offset -> Box -> (Box, Box)+cutBottom height parent =+  Box.withTRBL parent \t r b l ->+    let+      edge = b - height+    in+      ( Box.fromTRBL t r edge l+      , Box.fromTRBL edge r b l+      )++{-# INLINE splitLeft #-}+splitLeft :: Origin -> Box -> (Box, Box)+splitLeft origin parent =+  withVec2 parent.size \w _h ->+    cutLeft (w * origin) parent++{-# INLINE splitRight #-}+splitRight :: Origin -> Box -> (Box, Box)+splitRight origin parent =+  withVec2 parent.size \w _h ->+    cutRight (w * origin) parent++{-# INLINE splitTop #-}+splitTop :: Origin -> Box -> (Box, Box)+splitTop origin parent =+  withVec2 parent.size \_w h ->+    cutTop (h * origin) parent++{-# INLINE splitBottom #-}+splitBottom :: Origin -> Box -> (Box, Box)+splitBottom origin parent =+  withVec2 parent.size \_w h ->+    cutBottom (h * origin) parent++attachLeft :: Offset -> Box -> Box -> Box+attachLeft offset parent box =+  withVec2 parent.position \px py ->+    withVec2 parent.size \pw _ph ->+      withVec2 box.size \w _h ->+        let+          pleft = px - pw * 0.5+          right = pleft - offset+        in+          box+            { position =+                vec2 (right - w * 0.5) py+            }++attachRight :: Offset -> Box -> Box -> Box+attachRight offset parent box =+  withVec2 parent.position \px py ->+    withVec2 parent.size \pw _ph ->+      withVec2 box.size \w _h ->+        let+          pright = px + pw * 0.5+          left = pright + offset+        in+          box+            { position =+                vec2 (left + w * 0.5) py+            }++alignV :: Origin -> Box -> Box -> Box+alignV origin parent box =+  withVec2 parent.position \_px py ->+    withVec2 parent.size \_pw ph ->+      withVec2 box.position \x _y ->+        withVec2 box.size \_w h ->+          let+            (before, after) = Alignment.placeSize1d origin h ph+            y' = py + before * 0.5 - after * 0.5+          in+            box+              { position =+                  vec2 x y'+              }++attachTop :: Float -> Box -> Box -> Box+attachTop offset parent box =+  withVec2 parent.position \px py ->+    withVec2 parent.size \_pw ph ->+      withVec2 box.size \_w h ->+        let+          ptop = py - ph * 0.5+          bottom = ptop - offset+        in+          box+            { position =+                vec2 px (bottom - h * 0.5)+            }++attachBottom :: Float -> Box -> Box -> Box+attachBottom offset parent box =+  withVec2 parent.position \px py ->+    withVec2 parent.size \_pw ph ->+      withVec2 box.size \_w h ->+        let+          pbottom = py + ph * 0.5+          top = pbottom + offset+        in+          box+            { position =+                vec2 px (top + h * 0.5)+            }++alignH :: Origin -> Box -> Box -> Box+alignH origin parent box =+  withVec2 parent.position \px _py ->+    withVec2 parent.size \pw _ph ->+      withVec2 box.position \_x y ->+        withVec2 box.size \w _h ->+          let+            (before, after) = Alignment.placeSize1d origin w pw+            x' = px + before * 0.5 - after * 0.5+          in+            box+              { position =+                  vec2 x' y+              }++{-# INLINEABLE placeSize #-}+placeSize :: Alignment -> Vec2 -> Box -> Box+placeSize align size parent =+  withVec2 align \ah av ->+    withVec2 size \w h ->+      withVec2 parent.size \pw ph ->+        let+          (leftoversL, leftoversR) = Alignment.placeSize1d ah w pw+          (leftoversT, leftoversB) = Alignment.placeSize1d av h ph+        in+          Box.addPadding+            (TRBL $ vec4 leftoversT leftoversR leftoversB leftoversL)+            parent++{-# INLINEABLE placeAspect #-}+placeAspect :: Alignment -> Vec2 -> Box -> Box+placeAspect align aspect parent =+  withVec2 aspect \aw ah ->+    withVec2 parent.size \pw ph ->+      let+        scale =+          if pw / ph > aw / ah then+            ph / ah+          else+            pw / aw+      in+        placeSize align (aspect ^* scale) parent
+ src/Geomancy/Layout/Alignment.hs view
@@ -0,0 +1,68 @@+module Geomancy.Layout.Alignment where++import Geomancy++-- | @left/center/right@ & @top/middle/bottom@+type Alignment = Vec2++leftTop :: Alignment+leftTop = vec2 Begin Begin++leftMiddle :: Alignment+leftMiddle = vec2 Begin Middle++leftBottom :: Alignment+leftBottom = vec2 Begin End++centerTop :: Alignment+centerTop = vec2 Middle Begin++center :: Alignment+center = vec2 Middle Middle++centerBottom :: Alignment+centerBottom = vec2 Middle End++rightTop :: Alignment+rightTop = vec2 End Begin++rightMiddle :: Alignment+rightMiddle = vec2 End Middle++rightBottom :: Alignment+rightBottom = vec2 End End++type Origin = Float++pattern Begin :: Origin+pattern Begin = 0.0++pattern Middle :: Origin+pattern Middle = 0.5++pattern End :: Origin+pattern End = 1.0++{- | Distribute size difference according to origin.++@+(before, after) = placeSize1d _origin size target+before + size + after === target++placeBegin = placeSize1d 0+(0.0, 1.0) = placeBegin 1.0 2.0++placeMiddle = placeSize1d 0.5+(1.0, 1.0) = placeMiddle 1.0 3.0++placeEnd = placeSize1d 1.0+(1.0, 0.0) = placeEnd 1.0 2.0+@+-}+{-# INLINE placeSize1d #-}+placeSize1d :: Origin -> Float -> Float -> (Float, Float)+placeSize1d origin size target = (before, after)+  where+    leftovers = target - size+    before = leftovers * origin+    after = leftovers - before
+ src/Geomancy/Layout/Box.hs view
@@ -0,0 +1,299 @@+module Geomancy.Layout.Box where++import Prelude hiding (or)+import Geomancy++import Control.Monad (when)+import Foreign qualified+import Geomancy.Mat4 qualified as Mat4+import GHC.Generics (Generic)+import Graphics.Gl.Block qualified as Block++{- | 2D rectangle with its origin at the center.++Size transformations don't affect its position and vice versa.++@+┏━━━━━┓+┃     ┃+┃  *  ┃+┃     ┃+┗━━━━━┛+@+-}+data Box = Box+  { position :: Vec2+  , size     :: Vec2+  }+  deriving stock (Eq, Ord, Show, Generic)+  deriving anyclass Block.Block+  deriving Foreign.Storable via (Block.Packed Box)++-- | Place a 'Box' with given dimensions at @(0,0)@.+{-# INLINE box_ #-}+box_ :: Vec2 -> Box+box_ = Box 0++instance Semigroup Box where+  {-# INLINE (<>) #-}+  (<>) = union++-- | Check if one of the dimensions is negative.+{-# INLINE degenerate #-}+degenerate :: Box -> Bool+degenerate box =+  withVec2 box.size \w h ->+    w <= 0 ||+    h <= 0++-- | Move the 'Box' by the given vector.+{-# INLINE move #-}+move :: Vec2 -> Box -> Box+move delta box = box+  { position =+      box.position + delta+  }++-- | Adjust 'Box' size by a given amount (absolute).+{-# INLINE resize #-}+resize :: Vec2 -> Box -> Box+resize delta box = box+  { size =+      box.size + delta+  }++-- | Adjust 'Box' size by a given amount (relative).+{-# INLINE rescale #-}+rescale :: Vec2 -> Box -> Box+rescale delta box = box+  { size =+      box.size * delta+  }++-- * Edge representation++-- | Packed top- right- bottom- left- edge values.+newtype TRBL = TRBL Vec4+  deriving stock (Eq, Ord, Show, Generic)++instance Semigroup TRBL where+  {-# INLINE (<>) #-}+  TRBL a <> TRBL b =+    withVec4 a \at ar ab al ->+      withVec4 b \bt br bb bl ->+        TRBL $ vec4 (min at bt) (min ar br) (min ab bb) (max al bl)++type WithTRBL r = Float -> Float -> Float -> Float -> r++{-# INLINE fromTRBL #-}+fromTRBL :: WithTRBL Box+fromTRBL t r b l =+  Box+    { position =+        -- XXX: recover midpoint+        vec2+          (l * 0.5 + r * 0.5)+          (t * 0.5 + b * 0.5)+    , size =+        -- XXX: recover size+        vec2 (r - l) (b - t)+    }++{-# INLINE toTRBL #-}+toTRBL :: Box -> TRBL+toTRBL box = TRBL $ withTRBL box vec4++{-# INLINE withTRBL #-}+withTRBL :: Box -> WithTRBL r -> r+withTRBL Box{..} f =+  withVec2 position \x y ->+    withVec2 size \w h ->+      let+        t = y - h * 0.5+        r = x + w * 0.5+        b = y + h * 0.5+        l = x - w * 0.5+      in+        f t r b l++-- | Construct a smaller Box by adding non-uniform padding.+{-# INLINE addPadding #-}+addPadding :: TRBL -> Box -> Box+addPadding (TRBL padding) box =+  withVec4 padding \pt pr pb pl ->+    withTRBL box \t r b l ->+      fromTRBL (t + pt) (r - pr) (b - pb) (l + pl)++-- | Construct a smaller Box by adding non-uniform padding as a fraction of 'Box' size.+{-# INLINE addPaddingRel #-}+addPaddingRel :: TRBL -> Box -> Box+addPaddingRel (TRBL padding) box =+  withVec2 box.size \w h ->+    addPadding (TRBL $ padding * vec4 h w h w) box++-- | Construct a larger Box by adding non-uniform margins.+{-# INLINE addMargins #-}+addMargins :: TRBL -> Box -> Box+addMargins (TRBL margins) box =+  withVec4 margins \mt mr mb ml ->+    withTRBL box \t r b l ->+      fromTRBL (t - mt) (r + mr) (b + mb) (l - ml)++-- | Construct a larger Box by adding non-uniform margins as a fraction of 'Box' size.+{-# INLINE addMarginsRel #-}+addMarginsRel :: TRBL -> Box -> Box+addMarginsRel (TRBL margins) box =+  withVec2 box.size \w h ->+    addMargins (TRBL $ margins * vec4 h w h w) box++-- * AABB representation++-- | Bounding box from 2 points, automatically sorted.+{-# INLINE fromCorners #-}+fromCorners :: Vec2 -> Vec2 -> Box+fromCorners a b =+  withVec2 a \ax ay ->+    withVec2 b \bx by ->+      fromTRBL (min ay by) (max ax bx) (max ay by) (min ax bx)++-- | 2-point AABB.+{-# INLINE toCorners #-}+toCorners :: Box -> (Vec2, Vec2)+toCorners box = withCorners box (,)++{-# INLINE withCorners #-}+withCorners :: Box -> (Vec2 -> Vec2 -> r) -> r+withCorners box f =+  withTRBL box \t r b l ->+    f (vec2 l t) (vec2 r b)++-- * Point-box interaction++-- | Project a point into the 'Box' space.+{-# INLINE projectInto #-}+projectInto :: Vec2 -> Box -> Vec2+projectInto point box = point - box.position++-- | Test if a point is within the 'Box' bounds.+{-# INLINE inside #-}+inside :: Vec2 -> Box -> Bool+inside point box =+  withVec2 (point `projectInto` box) \px py ->+    withVec2 (box.size / 2) \hw hh ->+      px > -hw && px < hw &&+      py > -hh && py < hh++whenInside :: Applicative m => Vec2 -> Box -> (Vec2 -> m ()) -> m ()+whenInside point box action =+  when (inside point box) $+    action (point `projectInto` box)++-- * Box-box interaction++-- | Test if a 'Box' can contain a given 'Box'.+{-# INLINE canContain #-}+canContain :: Box -> Box -> Bool+canContain outer inner =+  withVec2 inner.size \iw ih ->+    withVec2 outer.size \ow oh ->+      iw <= ow &&+      ih <= oh++-- | Test if a 'Box' fully contains a given 'Box'.+{-# INLINE contains #-}+contains :: Box -> Box -> Bool+contains outer inner =+  withTRBL outer \ot or ob ol ->+    withTRBL inner \it ir ib il ->+      it >= ot &&+      ir <= or &&+      ib <= ob &&+      il >= ol++{-# INLINE union #-}+-- | Get a 'Box' that tightly wraps both its elements.+union :: Box -> Box -> Box+union a b =+  withTRBL a \at ar ab al ->+    withTRBL b \bt br bb bl ->+      fromTRBL (min at bt) (max ar br) (max ab bb) (min al bl)++{- | Get an intersection between two boxes, if there is one.++Use faster `intersects` instead if only need a test.+-}+intersection :: Box -> Box -> Maybe Box+intersection a b =+  if degenerate candidate then+    Nothing+  else+    Just candidate+  where+    candidate = intersectionDirty a b++-- | Get a potentially-degenerate intersection between two boxes.+{-# INLINE intersectionDirty #-}+intersectionDirty :: Box -> Box -> Box+intersectionDirty a b =+  withTRBL a \at ar ab al ->+    withTRBL b \bt br bb bl ->+      fromTRBL (max at bt) (min ar br) (min ab bb) (max al bl)++{- | Box-box intersection test.++Any edge contact counts as intersection.+For area contact use 'intersection`, which is a little less efficient.+-}+{-# INLINE intersects #-}+intersects :: Box -> Box -> Bool+intersects a b =+  withTRBL a \at ar ab al ->+    withTRBL b \bt br bb bl ->+      at <= bb &&+      al <= br &&+      bl <= ar &&+      bt <= ab+-- TODO: SIMD `intersects`++{- | Remaining space when one box is placed inside another.++All positive when the box is fully inside.+Negative edges mean the box is "outside" in that direction.++@+addPadding (leftovers inner outer) inner === outer+addMargins (leftovers inner outer) outer === inner+@+-}+leftovers :: Box -> Box -> TRBL+leftovers a b =+  TRBL $ withLeftovers a b vec4++withLeftovers :: Box -> Box -> WithTRBL r -> r+withLeftovers a b f =+  withTRBL a \ta ra ba la ->+    withTRBL b \tb rb bb lb ->+      f+        (tb - ta)+        (ra - rb)+        (ba - bb)+        (lb - la)++-- * Conversion++-- | Build a transformation matrix to stretch a unit square and place it at depth 0.0.+{-# INLINE mkTransform #-}+mkTransform :: Box -> Transform+mkTransform = mkTransformZ 0.0++-- | Build a transformation matrix to stretch a unit square and place it at a given depth.+{-# INLINE mkTransformZ #-}+mkTransformZ :: Float -> Box -> Transform+mkTransformZ z Box{..} =+  withVec2 position \x y ->+    withVec2 size \w h ->+      Mat4.rowMajor+        w 0 0 0+        0 h 0 0+        0 0 1 0+        x y z 1