cube 0.1.0 → 0.2.0

raw patch · 6 files changed

+269/−128 lines, 6 filesdep ~bytestringnew-component:exe:housePVP ok

version bump matches the API change (PVP)

Dependency ranges changed: bytestring

API changes (from Hackage documentation)

Files

• ChangeLog.md +6/−0
• Language/Cube.hs +183/−112
• README.md +6/−4
• cube.cabal +24/−2
• sample/house.hs +17/−0
• tests/test.hs +33/−10

@@ -1,3 +1,9 @@+## 0.2.0++* Fix bug of rotation+* Add RFunctor to define Functor for Data.Set and other data.+* Add sample in cabal+ ## 0.1.0  * First Release

@@ -1,39 +1,111 @@-{-#LANGUAGE OverloadedStrings#-}-{-#LANGUAGE InstanceSigs#-}-{-#LANGUAGE Rank2Types#-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE Rank2Types #-} {-# LANGUAGE FlexibleInstances    #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE IncoherentInstances  #-}+{-# LANGUAGE StandaloneDeriving  #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RecordWildCards #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}  module Language.Cube (-  ToSTL(..)+  RSTL(..)+, Stl+, ToStl(..)+, Conjugate(..)+, Delta(..)+, RFunctor(..) , Quaternion(..) , Cube , Block(..)-, smap+, toSTL+, toCube , block , cube+, compaction+, flipTriangle , writeFileStl-, ds-, dx-, dy-, dz-, dr+, writeFileStlWithText+, printStl , nCube , surface' , surface-, house ) where  import qualified Data.Serialize as C import Data.Monoid import qualified Data.Set as S import qualified Data.ByteString.Lazy as BL+import qualified Data.ByteString.Builder as BL import Graphics.Formats.STL+import Control.Monad -class ToSTL a where-  toSTL :: a -> STL+-- | Ristricted STL+-- This is the almost same as STL of Graphics.Formats.STL.+-- This is used to instantiate RFunctor of STL.+-- RFunctor provides a function(rfmap) like fmap of Functor.+data RSTL a =+  Stl {+    stlData :: STL+  } +-- | Wrapper of RSTL+type Stl = RSTL Triangle++-- | Generate Ristricted STL+class ToStl a where+  toStl :: a -> Stl++-- | Generate STL from Ristricted STL+toSTL :: ToStl a => a -> STL+toSTL a = stlData $ toStl a++-- | class type of mathematical conjugate+class Conjugate a where+  conjugate :: a -> a++-- | Delta move and rotation for quaternion+class (Num a) => Delta a where+  -- | delta for x axis+  dx :: a+  -- | delta for y axis+  dy :: a+  -- | delta for z axis+  dz :: a+  -- | delta for real part of quaternion+  ds :: a+  -- | cons (theta/2) + i sin (theta/2) + j sin (theta/2)  + k sin (theta/2)  of  quaternion+  dr :: Float -- ^ radian+     -> a    -- ^ axes of routation+     -> a+  -- | Routation for quaternion+  dR :: Float -- ^ radian+     -> a    -- ^ axes of routation+     -> a    -- ^ Input Vector+     -> a+  -- | Routation for quaternion+  -- This is the same as dR.+  rotate :: Float -- ^ radian+         -> a    -- ^ axes of routation+         -> a    -- ^ Input Vector+         -> a+  rotate = dR++-- | Ristricted Functor+class RFunctor f a b where+  rfmap :: (a -> b) -> f a -> f b++-- | Functor of Set+instance (Ord a, Ord b) => RFunctor S.Set a b where+  rfmap = S.map++instance (Functor m) => RFunctor m a b where+  rfmap = fmap++instance RFunctor RSTL Triangle Triangle where+  rfmap func (Stl stl) = Stl $ stl {triangles = map func (triangles stl)}+ -- | Unit element of Cube. --  -- This is the same as quaternion.@@ -44,13 +116,32 @@ , uz :: a } deriving (Show,Eq,Ord) -type Cube = Quaternion Int+type Cube = Quaternion Float +instance Functor Quaternion where+  fmap func Quaternion{..} = Quaternion (func us) (func ux) (func uy) (func uz)++instance Num a => Conjugate (Quaternion a) where+  conjugate (Quaternion s x y z) = Quaternion s (-x) (-y) (-z)++instance Delta Cube where+  dx = Quaternion 0 1 0 0+  dy = Quaternion 0 0 1 0+  dz = Quaternion 0 0 0 1+  ds = Quaternion 1 0 0 0+  dr theta (Quaternion _s x y z) =  Quaternion (co 1) (si x) (si y) (si z)+    where+      co :: Float -> Float+      co v = cos (theta/2) * v+      si :: Float -> Float+      si v = sin (theta/2) * v+  dR theta a i = let r = (dr theta a)+                     tmp = fmap round (r * i * conjugate r) :: Quaternion Integer+                 in fmap fromIntegral tmp instance (Num a) => Monoid (Quaternion a) where   mappend a b = a + b    mempty = Quaternion 0 0 0 0 - instance (Num a) => Num (Quaternion a) where   (+) (Quaternion ax ay az ar) (Quaternion bx by bz br) =     Quaternion (ax+bx) (ay+by) (az+bz) (ar+br)@@ -66,8 +157,6 @@   signum (Quaternion ax ay az ar) = Quaternion (signum ax) (signum ay) (signum az) (signum ar)   fromInteger a = Quaternion (fromIntegral a) 0 0 0 ---norm2 :: Quaternion a -> a---norm2 (Quaternion s x y z) = s*s + x**n + y**n + z**n  -- | Set of Cube. -- This supports boolean operations on polygons.@@ -86,131 +175,126 @@     au <- S.toList a     bu <- S.toList b     return (au + bu)-  abs (Block a) = Block $ S.map abs a-  signum (Block a) = Block $ S.map signum a+  abs (Block a) = Block $ rfmap abs a+  signum (Block a) = Block $ rfmap signum a   fromInteger a = Block $ S.singleton $ fromInteger a --- | map for Block.-smap :: (Ord a,Ord b) => (a -> b) -> Block a -> Block b-smap func (Block elems) = Block $ S.map func elems+instance (Ord a, Ord b) => RFunctor Block a b where+  rfmap func Block{..} = Block $ rfmap func units +instance Num STL where+  (+) (STL an atri) (STL _bn btri) = STL an $ S.toList $ S.fromList (atri ++ btri)+  (-) (STL an atri) (STL _bn btri) = STL an $ S.toList $ S.fromList atri S.\\ S.fromList btri+  (*) _ _ = error "(*) is not defined for STL"+  abs _ = error "abs is not defined for STL"+  signum _ = error "signum is not defined for STL"+  fromInteger _ = error "fromInteger is not defined for STL"++instance Num Stl where+  (+) (Stl a) (Stl b) = Stl $ a + b+  (-) (Stl a) (Stl b) = Stl $ a - b+  (*) _ _ = error "(*) is not defined for STL"+  abs _ = error "abs is not defined for STL"+  signum _ = error "signum is not defined for STL"+  fromInteger _ = error "fromInteger is not defined for STL"+ -- | Utility function of generating Block from list of cube block :: (Ord a) => [a] -> Block a block elems = Block $ S.fromList elems  -- | Utility function of Cube 0 x y z cube :: Int -> Int -> Int -> Cube-cube x y z = Quaternion 0 x y z+cube x y z = Quaternion 0 (fromIntegral x) (fromIntegral y) (fromIntegral z) +-- | Utility function of generating Cube from list of Int toCube :: [Int] -> Cube-toCube [s,a,b,c] = Quaternion s a b c+toCube [s,x,y,z] = Quaternion (fromIntegral s) (fromIntegral x) (fromIntegral y) (fromIntegral z) toCube [a,b,c] = cube a b c toCube _ = error "toCube" +-- | Flip rotation of triangle+flipTriangle :: Triangle -> Triangle+flipTriangle (Triangle m (x,y,z)) = Triangle m (x,z,y) +deriving instance (Ord Triangle)+deriving instance (Eq Triangle)+deriving instance (Show Triangle) -instance ToSTL (Quaternion Int) where-  toSTL v = STL "" $ flip map tri2 $ \[t0,t1,t2] ->+instance ToStl STL where+  toStl a = Stl a++instance ToStl Stl where+  toStl a = a++instance Monoid STL where+  mappend (STL an at) (STL _bn bt) = STL an (at<>bt)+  mempty = STL "" []++instance Monoid Stl where+  mappend (Stl a) (Stl b) = Stl (a<>b)+  mempty = Stl mempty++instance ToStl Cube where+  toStl v = Stl $ STL "" $ flip map tri2 $ \[t0,t1,t2] ->       Triangle Nothing (          ve (t0 + v),          ve (t1 + v),          ve (t2 + v))     where-      ve (Quaternion _s a b c) = (fromIntegral a,fromIntegral b,fromIntegral c)+      ve (Quaternion _s a b c) = (a,b,c)       vec [a,b,c] =         case (b-a)*(c-a) + a of           Quaternion _s x y z | 0 <= x && x <=1  &&0 <= y && y <=1  && 0 <= z && z <=1 -> True                               | otherwise -> False       vec _ = error "vec"-      tri =  [map toCube [a,b,c] |-              a <- [[0,0,0],[0,1,1],[1,0,1],[1,1,0]],-              b <- cube0,-              c <- cube0,-              dist a b == 1,-              dist a c == 1,-              dist b c == 2,-              b < c ]-      +      o1  = [mempty,mempty + dx,mempty + dy]+      o2 = [mempty+dx+dy,mempty + dx,mempty + dy]+      o3 = map (+ dz) o1+      o4 = map (+ dz) o2+      o5 = map (dR (pi/2) dx) o1+      o6 = map (dR (pi/2) dx) o2+      o7 = map (+ dy) o5+      o8 = map (+ dy) o6+      o9 = map (dR (-pi/2) dy) o1+      o10 = map (dR (-pi/2) dy) o2+      o11 = map (+ dx) o9+      o12 = map (+ dx) o10+      tri = [o1,o2,o3,o4,o5,o6,o7,o8,o9,o10,o11,o12]       tri2 = map (\l@[a,b,c] -> if vec l then [a,c,b] else [a,b,c]) tri-      -      cube0 = do-        a <- [0,1]-        b <- [0,1]-        c <- [0,1]-        return [a,b,c]-      dist a b =  sum $ map abs $ map (uncurry (-)) $ zip a b --- instance (Real a,Fractional a, Num a) => ToSTL (Quaternion a) where---   toSTL v@(Quaternion _s x y z) = STL "" $ flip map tri2 $ \[t0,t1,t2] ->---       Triangle Nothing (---          ve (t0 + v),---          ve (t1 + v),---          ve (t2 + v))---     where---       ve (Quaternion _s a b c) = (realToFrac a,realToFrac b,realToFrac c)---       ve _ = error ""---       xyz = [x,y,z]---       cubeTriangle =  [(a,b,c) | a <- [[0,0,0],[0,1,1],[1,0,1],[1,1,0]],---                                  b <- cube0,---                                  c <- cube0,---                                  dist a b == 1,---                                  dist a c == 1,---                                  dist b c == 2,---                                  b < c ]---       cube0 = do---         a <- [0,1]---         b <- [0,1]---         c <- [0,1]---         return [a,b,c]---       dist a b =  sum $ map abs $ map (uncurry (-)) $ zip a b -instance (ToSTL a) => ToSTL (Block a) where-  toSTL (Block sets) = foldr (<>) mempty $ map toSTL $ S.toList sets--instance Monoid STL where-  mappend (STL an at) (STL _bn bt) = STL an (at<>bt)-  mempty = STL "emptry" []+instance (ToStl a) => ToStl (Block a) where+  toStl (Block sets) = compaction $ foldr (<>) mempty $ map toStl $ S.toList sets  instance (Ord a, Monoid a) => Monoid (Block a) where   mappend (Block a) (Block b) = Block (a<>b)   mempty = Block $ S.singleton mempty --- | Generate STL file from Block-writeFileStl :: ToSTL a => String -> a -> IO ()+-- | Remove redundant triangles+compaction :: Stl -> Stl+compaction stl =  stl - (rfmap flipTriangle stl)++-- | Generate binary STL file from Block+writeFileStl :: ToStl a => String -> a -> IO () writeFileStl filename stl = BL.writeFile filename $ C.encodeLazy $ toSTL stl --- | Unit vector of Z direction-dz :: Cube-dz = Quaternion 0 0 0 1+-- | Generate text STL file from Block+writeFileStlWithText :: ToStl a => String -> a -> IO ()+writeFileStlWithText filename stl = BL.writeFile filename $ BL.toLazyByteString $ textSTL $ toSTL stl --- | Unit vector of Y direction-dy :: Cube-dy = Quaternion 0 0 1 0+-- | Print triangles of STL+printStl :: ToStl a => a -> IO ()+printStl stl = do+  let tris = triangles $ toSTL stl+  forM_ tris $ \t -> do+    print $ t --- | Unit vector of X direction-dx :: Cube-dx = Quaternion 0 1 0 0 --- | Unit scalar vector-ds :: Cube-ds = Quaternion 1 0 0 0---- | Vector for generating routation vector-dr :: Float -- ^ radian-   -> Cube -- ^ axes of routation-   -> Cube-dr theta (Quaternion _s x y z) =  Quaternion (co 1) (si x) (si y) (si z)-  where-    co :: Int -> Int-    co v = round $ cos theta * fromIntegral v-    si :: Int -> Int-    si v = round $ sin theta * fromIntegral v- -- | This function genrates a cube of n-width. nCube :: Int -> Block Cube nCube n =   let lst = [0..(n-1)]-  in Block $ S.fromList [Quaternion 0 a b c | a <- lst,b <- lst,c <- lst]+  in Block $ S.fromList [cube a b c | a <- lst,b <- lst,c <- lst]  -- | Generate surface block. -- This is fast function. But shape becomes little bit bigger.@@ -227,16 +311,3 @@     cube2 :: Block Cube     cube2 = block $ [Quaternion 0 x y z| x<-[-2..2], y<-[-2..2], z<-[-2..2]] --- | Generate house which is for demo.-house :: Block Cube-house = let house''  = (house' + square)*line-        in smap (12 * dz +)  $ surface house''-  where-    house' :: Block Cube-    house' = block $ [Quaternion 0 1 x y| x<-[-10..10], y<-[-10..10], y < x , y < (-x)]-    -    square :: Block Cube-    square = smap ((+) (-12 * dz)) $ block $ [Quaternion 0 1 x y| x<-[-5..5], y<-[-5..5]]-    -    line :: Block Cube-    line = block $ [Quaternion 0 x 0 0 | x<-[-5..5]]

@@ -24,18 +24,20 @@   ```+import Language.Cube+ house :: Block Cube house = let house''  = (house' + square)*line-        in smap (12 * dz +)  $ surface house''+        in rfmap (12 * dz +) house''   where     house' :: Block Cube-    house' = block $ [Cube 0 1 x y| x<-[-10..10], y<-[-10..10], y < x , y < (-x)]+    house' = block $ [cube 1 x y| x<-[-10..10], y<-[-10..10], y < x , y < (-x)]          square :: Block Cube-    square = smap ((+) (-12 * dz)) $ block $ [Cube 0 1 x y| x<-[-5..5], y<-[-5..5]]+    square = rfmap ((+) (-12 * dz)) $ block $ [cube 1 x y| x<-[-5..5], y<-[-5..5]]          line :: Block Cube-    line = block $ [Cube 0 x 0 0 | x<-[-5..5]]+    line = block $ [cube x 0 0 | x<-[-5..5]] main :: IO () main = do   writeFileStl "house.stl" $ house

@@ -1,5 +1,5 @@ name:                cube-version:             0.1.0+version:             0.2.0 synopsis:            Cubic DSL for 3D printing description:         Cube is DSL for 3D printing.                      .@@ -31,6 +31,10 @@   type:           git   location:       https://github.com/junjihashimoto/cube.git +flag sample+  description: Build sample programs+  default: False+ library   exposed-modules:     Language.Cube   -- other-modules:       @@ -38,11 +42,29 @@   build-depends:       base >=4 && <5                      , STL                      , cereal-                     , bytestring+                     , bytestring >= 0.10.2                      , containers   -- hs-source-dirs:         default-language:    Haskell2010   ghc-options:       -Wall++executable house+  if flag(sample)+    buildable: True+  else+    buildable: False+  ghc-options:       -Wall+  build-depends:       base >=4 && <5+                     , cube+                     , STL+                     , cereal+                     , bytestring+                     , containers+                     , hspec+  hs-source-dirs:    sample+  main-is:           house.hs+  Extensions:        DeriveDataTypeable+  test-suite test   type:              exitcode-stdio-1.0

@@ -0,0 +1,17 @@+import Language.Cube++house :: Block Cube+house = let house''  = (house' + square)*line+        in rfmap (12 * dz +) house''+  where+    house' :: Block Cube+    house' = block $ [cube 1 x y| x<-[-10..10], y<-[-10..10], y < x , y < (-x)]+    +    square :: Block Cube+    square = rfmap ((+) (-12 * dz)) $ block $ [cube 1 x y| x<-[-5..5], y<-[-5..5]]+    +    line :: Block Cube+    line = block $ [cube x 0 0 | x<-[-5..5]]+main :: IO ()+main = do+  writeFileStl "house.stl" $ house

@@ -2,10 +2,26 @@ {-#LANGUAGE FlexibleContexts#-} {-#LANGUAGE TemplateHaskell#-} {-#LANGUAGE QuasiQuotes#-}+{-#LANGUAGE ScopedTypeVariables#-}  import Test.Hspec import Language.Cube+import Graphics.Formats.STL +-- | Generate house which is for demo.+house :: Block Cube+house = let house''  = (house' + square)*line+        in rfmap (12 * dz +) house''+  where+    house' :: Block Cube+    house' = block $ [cube 1 x y| x<-[-10..10], y<-[-10..10], y < x , y < (-x)]+    +    square :: Block Cube+    square = rfmap ((+) (-12 * dz)) $ block $ [cube 1 x y| x<-[-5..5], y<-[-5..5]]+    +    line :: Block Cube+    line = block $ [cube x 0 0 | x<-[-5..5]]+ main :: IO () main =    hspec $ do@@ -23,26 +39,33 @@       it "-2 * dx" $ do         (-2) * dx `shouldBe` cube (-2) 0 0        it "route pi/2" $ do-        (dr (pi/2) dz) * dx `shouldBe` cube 0 1 0+        (dR (pi/2) dz dx) `shouldBe` cube 0 1 0       it "route pi" $ do-        (dr (pi) dz) * dx `shouldBe` cube (-1) 0 0+        (dR (pi) dz dx) `shouldBe` cube (-1) 0 0       it "route 3*pi/2" $ do-        (dr (3*pi/2) dz) * dx `shouldBe` cube 0 (-1) 0+        (dR (3*pi/2) dz dx) `shouldBe` cube 0 (-1) 0       it "route 2*pi" $ do-        (dr (2*pi) dz) * dx `shouldBe` cube 1 0 0+        (dR (2*pi) dz dx) `shouldBe` cube 1 0 0       it "multi" $ do-        dx * dy `shouldBe` dz+        dx * dy `shouldBe` (dz :: Cube)       it "multi" $ do-        dy * dx `shouldBe` (-dz)+        dy * dx `shouldBe` (-dz :: Cube)     describe "Block" $ do       it "dx" $ do-        block [dx,dx] `shouldBe` block [dx]+        block [dx,dx] `shouldBe` (block [dx] :: Block Cube)       it "dx+dy" $ do-        block [dx] + block [dy] `shouldBe` block [dx,dy]+        block [dx] + block [dy] `shouldBe` (block [dx,dy] :: Block Cube)       it "[dx,dy]-dy" $ do-        block [dx,dy] - block [dy] `shouldBe` block [dx]+        block [dx,dy] - block [dy] `shouldBe` (block [dx] :: Block Cube)       it "convolution(dx * [-2*dx,2*dx])" $ do-        block [dx] * block [-2*dx,2*dx] `shouldBe` block [-dx,3*dx]+        block [dx] * block [-2*dx,2*dx] `shouldBe` (block [-dx,3*dx] :: Block Cube)+    describe "Compaction" $ do+      it "num triangle of one block" $ do+        length (triangles (toSTL (block [dx] :: Block Cube))) `shouldBe` 12+      it "num triangle of two block" $ do+        length (triangles (toSTL (block [dx,2*dx] :: Block Cube))) `shouldBe` 20+      it "flip triangle" $ do+        (flipTriangle (Triangle Nothing ((5.0,0,0),(1,0,0),(2,0,0)))) `shouldBe` (Triangle Nothing ((5.0,0,0),(2,0,0),(1,0,0)))     describe "ToSTL" $ do       it "Block Cube" $ do         writeFileStl "tmp.stl" (block [dx] :: Block Cube) `shouldReturn` ()