ascii-holidays 0.1.0.0 → 0.1.0.1

raw patch · 4 files changed

+248/−3 lines, 4 files

Files

• BashTree.hs +66/−0
• PerlTree.hs +91/−0
• Util.hs +85/−0
• ascii-holidays.cabal +6/−3

@@ -0,0 +1,66 @@+module BashTree (drawBashTree) where++import Util++bashTriHeight, bashTrunkHeight, bashTreeHeight, bashNumOrnaments :: Int+bashTriHeight = 10 -- 38+bashTrunkHeight = 2+bashTreeHeight = bashTriHeight + bashTrunkHeight+bashNumOrnaments = 35++drawBashTree :: IO ()+drawBashTree = do+   g <- newStdGen+   nextYear <- getNextYear+   term <- setupTermFromEnv+   let Just width = getCapability term termColumns+       centerCol = width `div` 2+   writeAt <- getWriteAt term+   mapM_ writeAt $+      bashTri centerCol+      ++ bashTrunk centerCol+      ++ [ Write (bashTreeHeight + 2) (centerCol - 8)  Bold Red "MERRY CHRISTMAS"+         , Write (bashTreeHeight + 3) (centerCol - 12) Bold Red $ "And lots of CODE in " ++ show nextYear+         ]+   forM_ (zip (cycle builtInColors) (randPoss centerCol g)) $ \(c, (oldPos, (newRow, newCol))) -> do+      case oldPos of+         Nothing -> pure ()+         -- "Clean up" an ornament:+         Just (a, b) -> writeAt $ Write a b Bold Green "*"+      -- Place a new ornament:+      writeAt $ Write newRow newCol Bold c "o"+      forM_ (zip "CODE" [centerCol ..]) $ \(char, row) -> do+         writeAt $ Write (bashTriHeight + bashTrunkHeight + 3) row Bold c [char]+         threadDelay (10^(5::Int))++allBashTreePositions :: Int -> [(Int, Int)]+allBashTreePositions centerCol =+   (`concatMap` [1..bashTriHeight]) $ \n ->+      [ (n+1, col) | col <- take ((n*2)-1) [centerCol - n ..]]++pickPos :: Int -> Int -> (Int, Int)+pickPos centerCol n =+   poss !! (abs n `mod` (length::[x]->Int) poss)+ where+   poss = allBashTreePositions centerCol++bashTri, bashTrunk :: Int -> [Write]+bashTri centerCol =+   [ Write row col Bold Green "*"+   | (row, col) <- allBashTreePositions centerCol+   ]+bashTrunk centerCol =+   [ Write col (centerCol - 2) Plain Yellow "mWm"+   | col <- take bashTrunkHeight [bashTriHeight + 2 ..]+   ]++-- The way it works in the other one is they lay down some number of 'lights', then after that number is present, they remove the oldest first each time they add a new one++-- The fst Maybe is the ornament that we may want to clean up+-- TODO: keep a list of all that are on - each time you add a new one, remove one. don't select the same one twice. use shuffle or 'pick', should be easy.+randPoss :: RandomGen g => Int -> g -> [(Maybe (Int, Int), (Int, Int))]+randPoss centerCol g =+   zip (replicate bashNumOrnaments Nothing ++ map Just randPos) randPos+ where+   randPos :: [(Int, Int)]+   randPos = map (pickPos centerCol) $ randoms g

@@ -0,0 +1,91 @@+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+      ]

@@ -0,0 +1,85 @@+-- Reimplementation of:+--   Bash tree: https://github.com/sergiolepore/ChristBASHTree+--   Perl tree: https://github.com/rcaputo/acme-poe-tree++-- package name: 'ascii-holidays' , 'posix-holidays' etc++-- TODO: handle screen resizes++module Util (+     getWriteAt+   , Write(..)+   , Stroke(..)++   , getNextYear+   , builtInColors+   , chunksOf++   -- Re-exports:+   , module Control.Monad+   , shuffleM+   , threadDelay+   , newStdGen, RandomGen(..), randoms+   -- , module System.Console.TermInfo+   , Color(..), getCapability, setupTermFromEnv, termColumns, termLines+   ) where++import Control.Concurrent (threadDelay)+import Control.Monad (forM_)+import Data.Time (toGregorian, utctDay, getCurrentTime)+import System.Console.Terminfo hiding (row, col)+import System.Random (randoms, RandomGen(..), newStdGen)+import System.Random.Shuffle (shuffleM)++data Stroke = Bold | Plain | Dim++-- TODO: rename+data Write = Write Int Int Stroke Color String++-- from https://rosettacode.org/wiki/Spinning_rod_animation/Text#Haskell :+-- TODO: maybe remove?:+runCapability :: Terminal -> String -> IO ()+runCapability term cap =+    forM_ (getCapability term (tiGetOutput1 cap)) (runTermOutput term)++-- Could see how many more we can work with with 'termColors' and 'ColorNumber':+builtInColors :: [Color]+builtInColors = [Black, Red, Green, Yellow, Blue, Magenta, Cyan, White]++getNextYear :: IO Integer+getNextYear = do+   (thisYear, _, _) <- (toGregorian . utctDay) <$> getCurrentTime+   pure $ thisYear + 1++getWriteAt :: Terminal -> IO (Write -> IO ())+getWriteAt term = do+   let Just gotoPos = getCapability term cursorAddress+       Just withFGColor = getCapability term withForegroundColor+       Just makeBold = getCapability term withBold+       Just clear = getCapability term clearScreen+       Just numLines = getCapability term termLines+       Just withAttrs = getCapability term withAttributes+   runCapability term "civis" -- Make cursor invisible+   runTermOutput term $ clear numLines+   pure $ \(Write row col stroke color s) -> do+      runTermOutput term $ gotoPos $ Point row col+      let f = case stroke of+             Bold -> makeBold -- Setting bold twice to be sure; may very well be redundant+             _ -> id+          attrs = defaultAttributes{+               invisibleAttr = True -- Doesn't seem to work; that's why we had to "civis" above+             , dimAttr = case stroke of+                 Dim -> True+                 _ -> False+             , boldAttr = case stroke of+                 Bold -> True+                 _ -> False+             }+      runTermOutput term $ withAttrs attrs $ f $ withFGColor color $ termText s++-- So we don't need to depend on 'split':+chunksOf :: Int -> [x] -> [[x]]+chunksOf n l = case splitAt n l of+   ([], []) -> []+   (x, []) -> [x]+   (x, xs) -> x : chunksOf n xs

@@ -1,6 +1,6 @@ cabal-version:       >=1.10 name:                ascii-holidays-version:             0.1.0.0+version:             0.1.0.1 synopsis:            ASCII animations for the holidays! description:   ASCII animations for various holidays. Currently two animations, both for@@ -13,7 +13,7 @@ license:             GPL-3 license-file:        LICENSE author:              Tom Murphy--- maintainer:+maintainer:          Tom Murphy -- copyright: category:            Graphics build-type:          Simple@@ -21,7 +21,10 @@  executable ascii-holidays   main-is:             Main.hs-  -- other-modules:+  other-modules:+      BashTree+    , PerlTree+    , Util   -- other-extensions:   build-depends:       base <5