Unix cal(1) knockoff in Common Lisp / Haskell

cal-short.hs

import Data.List (transpose, unfoldr, intercalate)
import Data.Time.Calendar (gregorianMonthLength, fromGregorian)
import Data.Time.Calendar.WeekDate (toWeekDate)

-- utilities
dow y m d = pred $ trd $ toWeekDate $ fromGregorian y m d  where trd(_,_,x) = x
groupsOf n | n>0 = unfoldr $ \x -> if null x then Nothing else Just(splitAt n x)

-- essential start of cal.hs --------------------------------------
type Month = (Integer,Int)      -- a local definition of handy month
makeMonth :: Integer -> Int -> Month
makeMonth y i = (y + fromIntegral q, r+1) where (q,r) = (i-1) `quotRem` 12 

-- string generation staff (maybe shortened with good sprintf function...)
monthHeadingRow (y,m) = "      " ++ mnms!!(m-1) ++ " " ++ show y ++ "       "
mnms = ["Jan","Feb","Mar","Apr","May","Jun","Jul","Aug","Sep","Oct","Nov","Dec"]
dowRow   = concatMap (++" ") $ take 7 $ drop ix0 dowNames
dowNames = cycle ["Mo", "Tu", "We", "Th", "Fr", "Sa", "Su"]
ix0 = 0
weeks (y,m) = groupsOf 7 $ pad(dow y m 1-ix0) ++ [1..ml] ++ pad(ix0-1-dow y m ml)
  where ml  = gregorianMonthLength y m
        pad = flip replicate 0 . (`mod`7)
weekRow days = concatMap ((++" ") . dayStr) days
  where dayStr n | n>9 = show n | n>0 = " " ++ show n | otherwise = "  "

genMonthRows ym = monthHeadingRow ym : dowRow : map weekRow (weeks ym)
emptyRow = replicate (3*7) ' '

-- layout formatting staff
addPadRows rowsList = zipWith (++) rowsList padsList
  where lenList  = map length rowsList
        maxLen   = maximum lenList
        padsList = map (flip replicate emptyRow . (maxLen-)) lenList
genGroupLines= map (intercalate" ") . transpose . addPadRows . map genMonthRows
genCalLines = intercalate [""] . map genGroupLines . groupsOf 3 . enumMonths 
enumMonths (y,m,n) = map (makeMonth y) [m..m+n-1]
printCal year startMonth n = mapM_ putStrLn $ genCalLines (year,startMonth,n)

cal.hs

import Data.List (transpose, unfoldr, intercalate)
import Data.Time.Calendar (gregorianMonthLength, fromGregorian)
import Data.Time.Calendar.WeekDate (toWeekDate)

-- utilities

dow :: Integer -> Int -> Int -> Int
dow y m d = pred $ trd $ toWeekDate $ fromGregorian y m d  where trd(_,_,x) = x

groupsOf :: Int -> [a] -> [[a]]
groupsOf n | n>0 = unfoldr $ \x -> if null x then Nothing else Just(splitAt n x)

-- essential start of cal.hs --------------------------------------

type Month = (Integer,Int)      -- a local definition of handy month

makeMonth :: Integer -> Int -> Month
makeMonth y i = (y + fromIntegral q, r+1) where (q,r) = (i-1) `quotRem` 12 

-- string generation staff (maybe shortened with good sprintf function...)

monthHeadingRow :: Month -> String -- 6 + 3 + 1 + 4 + 7 = 21
monthHeadingRow m = "      " ++ monthName m ++ " " ++ yearName m ++ "       "
yearName  (y,_) = show y 
monthName (_,m) = mnms !! (m-1)
mnms = ["Jan","Feb","Mar","Apr","May","Jun","Jul","Aug","Sep","Oct","Nov","Dec"]
dowRow   = concatMap (++" ") $ take 7 $ drop ix0 dowNames :: String
dowNames = cycle ["Mo", "Tu", "We", "Th", "Fr", "Sa", "Su"]
ix0 = 0                         -- normally 0 (Monday) or 6 (Sunday)
weeks :: Month -> [[Int]]
weeks (y,m) = groupsOf 7 $ pad(dow y m 1-ix0) ++ [1..ml] ++ pad(ix0-1-dow y m ml)
  where ml  = gregorianMonthLength y m
        pad = flip replicate 0 . (`mod`7)
weekRow :: [Int] -> String
weekRow days = concatMap ((++" ") . dayStr) days
  where dayStr n | n>9 = show n | n>0 = " " ++ show n | otherwise = "  "

genMonthRows :: Month -> [String]
genMonthRows ym = monthHeadingRow ym : dowRow : map weekRow (weeks ym)

emptyRow = replicate (3*7) ' ' :: String

-- layout formatting staff

addPadRows :: [[String]] -> [[String]]
addPadRows rowsList = zipWith (++) rowsList padsList
  where lenList  = map length rowsList
        maxLen   = maximum lenList
        padsList = map (flip replicate emptyRow . (maxLen-)) lenList

genGroupLines :: [Month] -> [String] -- the months belong to the same horizon
genGroupLines= map (intercalate" ") . transpose . addPadRows . map genMonthRows

enumMonths :: (Integer,Int,Int) -> [Month]
enumMonths (y,m,n) = map (makeMonth y) [m..m+n-1]

genCalLines :: (Integer,Int,Int) -> [String]
genCalLines = intercalate [""] . map genGroupLines . groupsOf 3 . enumMonths

printCal :: Integer -> Int -> Int -> IO ()
printCal year startMonth n = mapM_ putStrLn $ genCalLines (year,startMonth,n)

{-
-- for self made version
import Control.Exception (assert)
import Data.List (transpose, unfoldr, intercalate)
dow :: Integer -> Int -> Int -> Int
dow y m d = assert (1752<=y && 1<=m && m<=12 && 1<=d && d<=31) (zeller y m d)
zeller :: Integer -> Int -> Int -> Int
zeller y m d =  fromIntegral offset `rem` 7
  where y' = if m<3 then y-1 else y
        offset = y' + quot y' 4 - quot y' 100 + quot y' 400
                 + [0,3,2,5,0,3,5,1,4,6,2,4] !! (m-1)
                 + fromIntegral d + 6
gregorianMonthLength :: Integer -> Int -> Int
gregorianMonthLength y m | 1<=m && m<= 12 = mmd (isLeapYear y) !! (m-1)
  where mmd True  = [31,29,31,30,31,30,31,31,30,31,30,31]
        mmd False = [31,28,31,30,31,30,31,31,30,31,30,31]
isLeapYear :: Integer -> Bool
isLeapYear y = zry 4 && not (zry 100) || zry 400  where zry = (0==) . rem y
-}

cal.lisp

;;; Unix cal(1) knockoff
;;; written by @nfunato on 2012/10/15 for some reason

(defvar $month-names '(nil "Jan" "Feb" "Mar" "Apr" "May" "Jun"
                           "Jul" "Aug" "Sep" "Oct" "Nov" "Dec"))
(defvar $dow-names-m '("Mo" "Tu" "We" "Th" "Fr" "Sa" "Su"))
(defvar $dow-names-s '("Su" "Mo" "Tu" "We" "Th" "Fr" "Sa"))
(defvar $dow-names   $dow-names-m)

(defparameter *dow-from-monday-p* t)

(defun toggle-dow-from-monday ()
  (prog1 (setf *dow-from-monday-p* (not *dow-from-monday-p*))
         (setf $dow-names (if *dow-from-monday-p* $dow-names-m $dow-names-s))))

(defun dow (y m d)
  (assert (and (<= 1752 y) (<= 1 m 12) (<= 1 d 31)))
  (let ((y (if (< m 3) (1- y) y)))
    (rem (+ y (truncate y 4) (- (truncate y 100)) (truncate y 400)
            (svref #(nil 0 3 2 5 0 3 5 1 4 6 2 4) m)
            d
            (if *dow-from-monday-p* 6 0))
         7)))

(defun leap-year-p (y)
  (flet ((zry (n) (zerop (rem y n))))
    (or (and (zry 4) (not (zry 100)))
        (zry 400))))

(defun month-max-day (y m)
  (assert (<= 1 m 12))
  (+ (if (and (leap-year-p y) (= m 2)) 1 0)
     (svref #(nil 31 28 31 30 31 30 31 31 30 31 30 31) m)))

(defun take (n xs)
  (loop for i from 0 below n
        for x in xs
        collect x))

(defun groups-of (n xs)
  (cond ((zerop n) (error "groups-of"))
        ((null xs) '())
        (t (cons (take n xs) (groups-of n (nthcdr n xs))))))

(defun make-month (y m)
  "Returns a month object, hereafter month-obj. Month-obj is equal to its month-shape in the current implementation."
  (month-shape y m))

(defun month-shape (y m)
  "Returns information for printing a month, hereafter month-shape."
  (assert (<= 1 m 12))
  (let* ((mmd   (month-max-day y m))
         (weeks (groups-of 7
                 (nconc (make-list (dow y m 1))
                        (loop for d from 1 to mmd collect d)
                        (make-list (- 6 (dow y m mmd)))))))
    (list* y m weeks)))

(defun shape-of (month-obj)
  month-obj)

(defun month->rowstrs (month-obj)
  (destructuring-bind (y m . weeks) (shape-of month-obj)
    (flet ((ym-str    () (format nil "~21:@<~a ~d~>" (nth m $month-names) y))
           (dow-str   () (format nil "~{~a ~}" $dow-names))
           (week-str (w) (format nil "~{~:[   ~;~:*~2,d ~]~}" w)))
      ;; each list item, which we call rowstr, has same length, i.e. 21
      (list* (ym-str) (dow-str) (mapcar #'week-str weeks)))))

(defun max-nelems (xss)
  (loop for xs in xss maximize (length xs)))

(defun nspace-string (n)
  (make-string n :initial-element #\space))

(defun append-padding-rows (rowstrs-list)
  (let ((max-nrows (max-nelems rowstrs-list))
        (padrow    (nspace-string (length (caar rowstrs-list)))))
    (mapcar (lambda (rowstrs)
              (let ((nrows (- max-nrows (length rowstrs))))
                (append rowstrs (make-list nrows :initial-element padrow))))
            rowstrs-list)))

(defun print-months-horizontally (month-obj-list)
  (let* ((rowstrs-list        (mapcar #'month->rowstrs month-obj-list))
         (padded-rowstrs-list (append-padding-rows rowstrs-list)))
    (apply #'mapc
           (lambda (&rest rowstr-list) (format t "~{~a~^ ~}~%" rowstr-list))
           padded-rowstrs-list)))

(defun print-groups-of-months (groups-of-month-objs)
  (flet ((pmh-to-string (month-objs)
           (with-output-to-string (*standard-output*)
             (print-months-horizontally month-objs))))
    (format t "~{~a~^~%~}" (mapcar #'pmh-to-string groups-of-month-objs))))

(defun make-month-sequence (year start-month nmonth)
  (loop for i from start-month below (+ start-month nmonth)
        collect (multiple-value-bind (dy m-1) (truncate (1- i) 12)
                  (make-month (+ year dy) (1+ m-1)))))

(defun print-calendar (year start-month nmonth)
  "An essential background implementation of CAL without optional parameter interface and argument checking."
  (print-groups-of-months
    (groups-of 3
      (make-month-sequence year start-month nmonth))))

(defun cal (y &optional (m 1 sup-m) (num (if sup-m 1 12)))
  "Main API. (CAL y m h) prints a calendar from month 'm' of year 'y' for 'n' months, with displaying in three columns. (CAL y m) is a synonym of (CAL y m 1), and (CAL y) is a synonym of (CAL y 1 12)."
  (assert (and (plusp y) (<= 1 m 12) (plusp num)))
  (print-calendar y m num))

;;; perhaps meaningful tests:
;;; (make-month 2010 8) (month->rowstrs (make-month 2010 8))
;;; (print-months-horizontally (list (make-month 2010 8)))
;;; (print-months-horizontally (make-month-sequences 2010 8 2))
;;; (cal 2010 1 3) (cal 2010 7 3) (cal 2012 7 3)
;;; (cal 2010 7) (cal 2010 8) (cal 2010 1) (cal 2010 2) (cal 2010 3)
;;; (cal 2010) (cal 2012 9 7)

;;; eof