Implementation of the Chapter 4.5 - Printing a calendar of the book Introduction to Functional Programming by Richard Bird and Philip Walder.
import Browser
import Html exposing (Html, div, li, text, ul, br, p, input)
import Html.Attributes exposing (placeholder, value, style)
import Html.Events exposing (onInput)
{-| Implementation of the
Chapter 4.5 - Printing a calendar
of the book Introduction to Functional Programming
by Richard Bird and Philip Walder
-}
type alias Matrix a = List (List a)
type alias Picture = Matrix String
flip : (a -> b -> c) -> b -> a -> c
flip f a b =
f b a
scanl : (a -> b -> b) -> b -> List a -> List b
scanl f b xs =
let
scan x accAcc =
case accAcc of
acc :: _ ->
(f x acc) :: accAcc
[] ->
[] -- impossible
in
List.reverse (List.foldl scan [b] xs)
height : Matrix a -> Int
height matrix =
List.length matrix
width : Matrix a -> Int
width matrix =
case List.head matrix of
Nothing -> 0
Just x -> List.length x
{-| Create a new picture by putting
one picture above another.
Works only if width p1 == width p2.
-}
above : Matrix a -> Matrix a -> Matrix a
above m1 m2 =
m1 ++ m2
{-| Create a new picture by stacking
a list of pictures.
-}
stack : List (Matrix a) -> Matrix a
stack ms =
case ms of
[] -> []
hd :: tl -> List.foldl (flip above) hd tl
{-| Create a new picture by putting
one picture beside another.
Works only if height p1 == height p2.
-}
beside : Matrix a -> Matrix a -> Matrix a
beside m1 m2 =
List.map2 (++) m1 m2
{-| Create a new picture by spreading
a list of pictures.
-}
spread : List (Matrix a) -> Matrix a
spread ms =
case ms of
[] -> []
hd :: tl -> List.foldl (flip beside) hd tl
{-| Returns a picture filled with spaces
with the specified height and width.
-}
empty : Int -> Int -> Picture
empty h w =
List.repeat h (List.repeat w "\u{00A0}")
{-| Create groups of elements of size n.
group 2 [ 1, 2, 3, 4 ] == [ [ 1, 2 ], [ 3, 4 ] ]
-}
group : Int -> List a -> List (List a)
group n xs =
case xs of
[] -> []
_ -> List.take n xs :: (group n (List.drop n xs))
{-| Create a new picture by making groups of size n of pictures,
putting them side by side, and then stacking them.
block 2 [ p1, p2, p3, p4, p5, p6 ]
p1 p2
p3 p4
p5 p6
-}
block : Int -> List Picture -> Picture
block n pictures =
pictures
|> group n
|> List.map spread
|> stack
{-| Transpose of the function block
-}
blockT : Int -> List Picture -> Picture
blockT n pictures =
pictures
|> group n
|> List.map stack
|> spread
{-| Put a picture in the top left corner of
an empty bigger picture with the specified
height and width
topLeftFrame 3 3 p
p _ _
_ _ _
_ _ _
-}
topLeftFrame : Int -> Int -> Picture -> Picture
topLeftFrame hFrame wFrame picture =
let
h = height picture
w = width picture
in
above (beside picture (empty hFrame (wFrame - w))) (empty (hFrame - h) wFrame)
displayRow : List String -> Html msg
displayRow list =
list
|> List.foldr (++) ""
|> text
{-| Display a picture as an Html element
-}
display : Picture -> List (Html msg)
display picture =
picture
|> List.map displayRow
|> List.intersperse (br [] [])
rjustify : Int -> String -> String
rjustify maxLength string =
if String.length string >= maxLength then
string
else
rjustify maxLength ("\u{00A0}" ++ string)
{-| Convert a string into a list of string
splitChar "abcd" == [ "a", "b", "c", "d" ]
-}
splitChar : String -> List String
splitChar string =
String.split "" string
-- CALENDAR
dayNames = [ "Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat" ]
monthNames =
[ "JANUARY"
, "FEBRUARY"
, "MARCH"
, "APRIL"
, "MAY"
, "JUNE"
, "JULY"
, "AUGUST"
, "SEPTEMBER"
, "OCTOBER"
, "NOVEMBER"
, "DECEMBER"
]
{-| Return the picture for the title
of the specified month
-}
title : String -> Int -> Picture
title monthName year =
let
mn = splitChar monthName
y = splitChar (String.fromInt year)
in
topLeftFrame 2 25 [ mn ++ [" "] ++ y ]
{-| Return the picture for the specified day
-}
date : Int -> Int -> Picture
date monthLength day =
if day < 1 || monthLength < day then
[ splitChar (rjustify 3 "") ]
else
[ splitChar (rjustify 3 (String.fromInt day)) ]
{-| Return the dates for the given month length
starting with the given day.
0 being Sunday, 1 being Monday, ... and 6 being Saturday.
-}
dates : Int -> Int -> List Picture
dates firstDay monthLength =
List.map (date monthLength) (List.range (1 - firstDay) (42 - firstDay))
{-| Return a month block with just the days.
entries 4 31
4 11 18 25
5 12 19 26
6 13 20 27
7 14 21 28
1 8 15 22 29
2 9 16 23 30
3 10 17 24 31
-}
entries : Int -> Int -> Picture
entries firstDay monthLength =
blockT 7 (dates firstDay monthLength)
{-| Return a month block with days and day of the week.
table 4 31
Sun 4 11 18 25
Mon 5 12 19 26
Tue 6 13 20 27
Wed 7 14 21 28
Thu 1 8 15 22 29
Fri 2 9 16 23 30
Sat 3 10 17 24 31
-}
table : Int -> Int -> Picture
table firstDay monthLength =
let
daynamesPicture = List.map splitChar dayNames
in
topLeftFrame 8 25 (beside daynamesPicture (entries firstDay monthLength))
{-| Return a month block with days,
day of the week and title.
picture "DECEMBER" 1991 4 31
DECEMBER 1991
Sun 4 11 18 25
Mon 5 12 19 26
Tue 6 13 20 27
Wed 7 14 21 28
Thu 1 8 15 22 29
Fri 2 9 16 23 30
Sat 3 10 17 24 31
-}
pic : String -> Int -> Int -> Int -> Picture
pic monthName year firstDay monthLength =
above (title monthName year) (table firstDay monthLength)
isLeapYear : Int -> Bool
isLeapYear year =
if (remainderBy 100 year) == 0 then
(remainderBy 400 year) == 0
else
(remainderBy 4 year) == 0
{-| Return the number of days for each month
of a given year.
-}
monthLengths : Int -> List Int
monthLengths year =
let
feb =
if isLeapYear year then 29
else 28
in [ 31, feb, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31 ]
{-| Return the first day of a given year.
-}
jan1Day : Int -> Int
jan1Day year =
remainderBy 7 (year + ((year - 1) // 4) - ((year - 1 ) // 100) + ((year - 1) // 400))
{-| Return the first day for each month
of a given year.
-}
firstDays : Int -> List Int
firstDays year =
List.map (remainderBy 7) (scanl (+) (jan1Day year) (monthLengths year))
{-| Return a list of pictures for each month
of a given year.
-}
monthPictures : Int -> List Picture
monthPictures year =
List.map4 pic monthNames (List.repeat 12 year) (firstDays year) (monthLengths year)
{-| Display a calendar for the given year
-}
calendar : Int -> List (Html msg)
calendar year =
monthPictures year
|> block 3
|> display
-- MAIN
type alias Model =
{ textInput : String
, result : Result String Int
}
type Msg
= Change String
main =
Browser.sandbox
{ init = init
, update = update
, view = view
}
init : Model
init =
{ textInput = "2019"
, result = Ok 2019
}
update : Msg -> Model -> Model
update msg model =
case msg of
Change string ->
let
newModel = { model | textInput = string }
in
case String.toInt string of
Just year ->
if year >= 0 then
{ newModel | result = Ok year }
else
{ newModel | result = Err "Year must be positive" }
Nothing ->
if String.length string == 0 then
{ newModel | result = Err "" }
else
{ newModel | result = Err "Can't convert string to int" }
view : Model -> Html Msg
view model =
case model.result of
Ok year ->
div
[]
[ input
[ placeholder "Year"
, value model.textInput
, onInput Change
]
[]
, div
[ style "font-family" "monospace"
, style "padding" "10px"
]
[ div [] (calendar year) ]
]
Err err ->
div
[]
[ input
[ placeholder "Year"
, value model.textInput
, onInput Change
]
[]
, div [] [ text err ]
]