cube (empty) → 0.1.0
raw patch · 7 files changed
+428/−0 lines, 7 filesdep +STLdep +basedep +bytestringsetup-changed
Dependencies added: STL, base, bytestring, cereal, containers, cube, hspec
Files
- ChangeLog.md +3/−0
- LICENSE +30/−0
- Language/Cube.hs +242/−0
- README.md +42/−0
- Setup.hs +2/−0
- cube.cabal +60/−0
- tests/test.hs +49/−0
+ ChangeLog.md view
@@ -0,0 +1,3 @@+## 0.1.0++* First Release
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2015, Junji Hashimoto++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 Junji Hashimoto 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.
+ Language/Cube.hs view
@@ -0,0 +1,242 @@+{-#LANGUAGE OverloadedStrings#-}+{-#LANGUAGE InstanceSigs#-}+{-#LANGUAGE Rank2Types#-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE IncoherentInstances #-}++module Language.Cube (+ ToSTL(..)+, Quaternion(..)+, Cube+, Block(..)+, smap+, block+, cube+, writeFileStl+, ds+, dx+, dy+, dz+, dr+, 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 Graphics.Formats.STL++class ToSTL a where+ toSTL :: a -> STL++-- | Unit element of Cube.+-- +-- This is the same as quaternion.+data Quaternion a = Quaternion {+ us :: a+, ux :: a+, uy :: a+, uz :: a+} deriving (Show,Eq,Ord)++type Cube = Quaternion Int++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)+ (-) (Quaternion ax ay az ar) (Quaternion bx by bz br) =+ Quaternion (ax-bx) (ay-by) (az-bz) (ar-br)+ (*) (Quaternion a1 b1 c1 d1) (Quaternion a2 b2 c2 d2) =+ Quaternion+ (a1*a2-b1*b2-c1*c2-d1*d2)+ (a1*b2+b1*a2+c1*d2-d1*c2)+ (a1*c2-b1*d2+c1*a2+d1*b2)+ (a1*d2+b1*c2-c1*b2+d1*a2)+ abs (Quaternion ax ay az ar) = Quaternion (abs ax) (abs ay) (abs az) (abs ar)+ 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.+-- (+) means or.+-- (-) means not.+-- (*) means convolution.+data Block a =+ Block {+ units :: S.Set a+ } deriving (Show,Eq,Ord)++instance (Ord a,Eq a,Num a) => Num (Block a) where+ (+) (Block a) (Block b) = Block $ a <> b+ (-) (Block a) (Block b) = Block $ (S.\\) a b+ (*) (Block a) (Block b) = Block $ S.fromList $ do+ 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+ 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++-- | 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++toCube :: [Int] -> Cube+toCube [s,a,b,c] = Quaternion s a b c+toCube [a,b,c] = cube a b c+toCube _ = error "toCube"++++instance ToSTL (Quaternion Int) where+ toSTL v = 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)+ 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 ]+ + 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 (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 ()+writeFileStl filename stl = BL.writeFile filename $ C.encodeLazy $ toSTL stl++-- | Unit vector of Z direction+dz :: Cube+dz = Quaternion 0 0 0 1++-- | Unit vector of Y direction+dy :: Cube+dy = Quaternion 0 0 1 0++-- | 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]++-- | Generate surface block.+-- This is fast function. But shape becomes little bit bigger.+surface' :: Block Cube -> Block Cube+surface' model = model * cube' - model+ where+ cube' :: Block Cube+ cube' = block $ [Quaternion 0 x y z| x<-[-1..1], y<-[-1..1], z<-[-1..1]]++-- | Generate surface block+surface :: Block Cube -> Block Cube+surface model = model - (model - (surface' model) * cube2)+ where+ 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]]
+ README.md view
@@ -0,0 +1,42 @@+# Cube: Cubic DSL for 3D printing++[](https://hackage.haskell.org/package/cube) [](https://travis-ci.org/junjihashimoto/cube)++Cube is DSL for 3D printing.++This indents to make original blocks and prototypes for hobby.++This DSL is based on mathematical algebra.+Cube is the same as Quaternion.+Block is set of Cube. It allows boolian operations(and, subtruct and convolution).++## Getting started++Install this from Hackage.++ cabal update && cabal install cube++## Example++Block is converted to STL.+Block is the same as set of cube.+Following example shows example of DSL generating shape of house.+++```+house :: Block Cube+house = let house'' = (house' + square)*line+ in smap (12 * dz +) $ surface house''+ where+ house' :: Block Cube+ house' = block $ [Cube 0 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]]+ + line :: Block Cube+ line = block $ [Cube 0 x 0 0 | x<-[-5..5]]+main :: IO ()+main = do+ writeFileStl "house.stl" $ house+```
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ cube.cabal view
@@ -0,0 +1,60 @@+name: cube+version: 0.1.0+synopsis: Cubic DSL for 3D printing+description: Cube is DSL for 3D printing.+ .+ This indents to make original blocks and prototypes for hobby.+ .+ This DSL is based on mathematical algebra.+ .+ Cube is the same as Quaternion.+ .+ Block is set of Cube. It allows boolean operations(and, subtruct and convolution).++license: BSD3+license-file: LICENSE+author: Junji Hashimoto+maintainer: junji.hashimoto@gmail.com+-- copyright: +category: Language+build-type: Simple+-- extra-source-files: +cabal-version: >=1.10++bug-reports: https://github.com/junjihashimoto/cube/issues++extra-source-files:+ ChangeLog.md+ README.md++source-repository head+ type: git+ location: https://github.com/junjihashimoto/cube.git++library+ exposed-modules: Language.Cube+ -- other-modules: + -- other-extensions: + build-depends: base >=4 && <5+ , STL+ , cereal+ , bytestring+ , containers+ -- hs-source-dirs: + default-language: Haskell2010+ ghc-options: -Wall++test-suite test+ type: exitcode-stdio-1.0+ main-is: test.hs+ hs-source-dirs: tests,dist/build/autogen+ ghc-options: -Wall++ build-depends: base >=4 && <5+ , cube+ , STL+ , cereal+ , bytestring+ , containers+ , hspec+ Default-Language: Haskell2010
+ tests/test.hs view
@@ -0,0 +1,49 @@+{-#LANGUAGE OverloadedStrings#-}+{-#LANGUAGE FlexibleContexts#-}+{-#LANGUAGE TemplateHaskell#-}+{-#LANGUAGE QuasiQuotes#-}++import Test.Hspec+import Language.Cube++main :: IO ()+main = + hspec $ do+ describe "Cube(quoternion)" $ do+ it "dx" $ do+ cube 1 0 0 `shouldBe` dx+ it "dy" $ do+ cube 0 1 0 `shouldBe` dy+ it "dz" $ do+ cube 0 0 1 `shouldBe` dz+ it "dx + dx" $ do+ dx + dx `shouldBe` cube 2 0 0 + it "2 * dx" $ do+ 2 * dx `shouldBe` cube 2 0 0 + 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+ it "route pi" $ do+ (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+ it "route 2*pi" $ do+ (dr (2*pi) dz) * dx `shouldBe` cube 1 0 0+ it "multi" $ do+ dx * dy `shouldBe` dz+ it "multi" $ do+ dy * dx `shouldBe` (-dz)+ describe "Block" $ do+ it "dx" $ do+ block [dx,dx] `shouldBe` block [dx]+ it "dx+dy" $ do+ block [dx] + block [dy] `shouldBe` block [dx,dy]+ it "[dx,dy]-dy" $ do+ block [dx,dy] - block [dy] `shouldBe` block [dx]+ it "convolution(dx * [-2*dx,2*dx])" $ do+ block [dx] * block [-2*dx,2*dx] `shouldBe` block [-dx,3*dx]+ describe "ToSTL" $ do+ it "Block Cube" $ do+ writeFileStl "tmp.stl" (block [dx] :: Block Cube) `shouldReturn` ()+ writeFileStl "house.stl" house `shouldReturn` ()