ascii-holidays-0.1.0.1: PerlTree.hs

module PerlTree (drawPerlTree) where

import Util

-- TODO: let people provide this as an option (command line)
perlDimBulbs :: Bool
perlDimBulbs = True

drawPerlTree :: IO ()
drawPerlTree = do
   -- TODO: paint background black?
   term <- setupTermFromEnv
   writeAt <- getWriteAt term
   -- TODO: just mod it or whatever to make sure it's odd:
   let Just width = getCapability term termColumns
       Just height = getCapability term termLines
       -- Just bg = getCapability term setBackgroundColor
   -- TODO: do this properly:
   -- (or maybe don't?)
   -- runTermOutput term $ bg Black -- $ termText "ok"
   potentialLightPoints <- shuffleM (pointsInsideTree (width`div`2) height)
   let lightColors :: [(Color, [(Int, Int)])]
       lightColors =
          zip perlLightColors $ chunksOf (length potentialLightPoints `div` (10 * length perlLightColors)) potentialLightPoints
   mapM_ writeAt $ perlTreeOutline (width `div` 2) height
   forM_ (cycle [False, True]) $ \b -> do
      g <- newStdGen
      mapM_ writeAt $ perlStar (width `div` 2) b
      forM_ lightColors $ \(color, points) ->
         forM_ (zip (randoms g) points) $ \(dim, (r, c)) -> do
            if perlDimBulbs
               then writeAt $ Write r c (if dim then Dim else case color of Yellow -> Plain ; _ -> Bold)  color "o"
               else writeAt $ Write r c (case color of Yellow -> Plain ; _ -> Bold) color (if dim then " " else "o")
      threadDelay (10^(6::Int))

perlLightColors :: [Color]
perlLightColors = [Blue, Yellow, Red, {- Purple -} Cyan, Green] -- , Magenta]

perlStar :: Int -> Bool -> [Write]
-- 'point0' is a way to say if we're in state 1 or 2 of the blinking:
perlStar centerCol point0 = [
     Write 1 centerCol wax      White "|"  -- 1 is the first one, - top of the star - not 0
   , Write 2 centerCol wane     White "|"
   , Write 4 centerCol wane     White "|"
   , Write 5 centerCol wax      White "|"

   , Write 3 (centerCol-3) wane White "-"
   , Write 3 (centerCol-2) wax  White "-"
   , Write 3 (centerCol-1) wane White "="

   , Write 3 (centerCol+1) wane White "="
   , Write 3 (centerCol+2) wax  White "-"
   , Write 3 (centerCol+3) wane White "-"

   , Write 2 (centerCol-1) wax  White "\\"
   , Write 2 (centerCol+1) wax  White "/"
   , Write 4 (centerCol-1) wax  White "/"
   , Write 4 (centerCol+1) wax  White "\\"

   , Write 3 centerCol (if point0 then Plain else Dim) (if point0 then Yellow else White) (if point0 then "O" else "o") -- the lowercase is my embellishment - not sure if I love it
   ]
 where
   wax = (if point0 then Bold else Dim)
   wane = (if point0 then Dim else Bold)

perlTreeOutline :: Int -> Int -> [Write]
perlTreeOutline centerCol height =
      [ Write r (centerCol-c) Plain Green "/"  | (r, c) <- oneSidePoints ]
   ++ [ Write r (centerCol+c) Plain Green "\\" | (r, c) <- oneSidePoints ]
 where
   oneSidePoints :: [(Int, Int)]
   oneSidePoints = perlTreeSide centerCol height

-- 'fst' is offset from center
perlTreeSide :: Int -> Int -> [(Int, Int)]
perlTreeSide centerCol height =
   -- 'tail' because first line is obscured by star:
   tail [
        (row, col)
      | row <- [4..(height-2)]
      , let col = ((row - 3) - (((row-4)`div`4)) {- * 2  ) * 2 -} ) {- <- also works -}
      , col <= centerCol -- Limit the height of the tree to whatever the width will also accommodate (test this by making the terminal really narrow)
      ]

pointsInsideTree :: Int -> Int -> [(Int, Int)]
pointsInsideTree centerCol height =
   filter (/= (5, centerCol)) $ -- This one is occupied by the star
   concat [
        [ (r, c) | c <- [(centerCol - (x-1))..(centerCol+(x-1))] ]
      | (r, x) <- perlTreeSide centerCol height
      ]