menger.hs

-- haskell code that spits out cgm3dt javascript calls to solidblock and point to create a menger sponge.

class JSObject a where
  to_js :: a -> String

class PtOffset a where
  add :: a -> CgmPt -> a

data CgmPt = CgmPt {
  x :: Double,
  y :: Double,
  z :: Double }
           deriving (Eq, Show)

instance JSObject CgmPt where
  to_js pt = "new point(" ++ (show (x pt)) ++ ", " ++ (show (y pt)) ++ ", " ++ (show (z pt)) ++ ")"

instance PtOffset CgmPt where
  add pt1 pt2 = CgmPt ( (x pt1) + (x pt2)) ( (y pt1) + (y pt2)) ( (z pt1) + (z pt2))

data CgmBlock = CgmBlock {
  pt :: CgmPt,
  dim :: CgmPt} deriving (Eq, Show)

instance JSObject CgmBlock where
  to_js blk = "new solidblock(" ++ (to_js (pt blk)) ++ ", " ++ (to_js (dim blk)) ++ ")"

instance PtOffset CgmBlock where
  add blk pt1 = CgmBlock (add (pt blk) pt1) (dim blk)

mkpt x y z = "new point(" ++ (show x) ++ ", " ++ (show y) ++ ", " ++ (show z) ++ ")"

-- data CgmBlock = CgmBlock CgmPt CgmPt
                
mksb x y z dx dy dz = "new solidblock(" ++ (mkpt x y z) ++ ", " ++ (mkpt (x+dx) (y+dy) (z+dz)) ++ ")"

menger :: Integer -> Double -> Double -> Double -> Double -> [CgmBlock]
menger 0 width x y z = [CgmBlock (CgmPt x y z) (CgmPt (x+width) (y+width) (z+width))]
menger level width x y z =
  let nl = level -1
      nw = width / 3.0
      xmw = x-nw
      xpw = x+nw
      ymw = y-nw
      ypw = y+nw
      zmw = z-nw
      zpw = z+nw
  in
   menger nl  nw xmw ymw zmw++
   menger nl  nw xmw ymw zmw++
   menger nl  nw xmw y zmw++
   menger nl  nw xmw ypw zmw++

   menger nl  nw xmw ymw z++
   menger nl  nw xmw ypw z++

   menger nl  nw xmw ymw zpw++
   menger nl  nw xmw y zpw++
   menger nl  nw xmw ypw zpw++


   menger nl  nw x ymw zmw++
   menger nl  nw x ypw zmw++

   menger nl  nw x ymw zpw++
   menger nl  nw x ypw zpw++

   menger nl  nw xpw ymw zmw++
   menger nl  nw xpw y zmw++
   menger nl  nw xpw ypw zmw++

   menger nl  nw xpw ymw z++
   menger nl  nw xpw ypw z++

   menger nl  nw xpw ymw zpw++
   menger nl  nw xpw y zpw++
   menger nl  nw xpw ypw zpw
  
main = do
  putStrLn (foldl (++) "" (map (\x -> (to_js x) ++ ";\n") (menger 3 200 0 0 0)))