module Main where
import System.Random
-------------------------------------------------------------------------------
-- Project 1, a Haskell version of the PR-1 program of Gottfried Michael Koenig
-- interpretation and programming: W.G. Vree, 2007
-------------------------------------------------------------------------------
-- For each "musical parameter" this program calculates a sequence of Parts.
-- The musical parameters are:
-- chords, duration (called entry-delay) dynamics and tempo.
-- A Part can be either a Row a Group or a Balance. 
-- Rows and Groups are sequences that obey certain rules of serial music.
-- A Balance is a (balanced) mixture of Rows and Groups.
-------------------------------------------------------------------------------

data Part a = Row [a] | Grp [a] | Bal [Part a] [Part a] | Par a

major :: [[Int]] -- explicit typing to force 32-bit integers (Int)
minor :: [[Int]] -- Haskell defaults to huge integers (Integer)
mapping :: [(String, Int, Int)]

-----------------------------------------------------------------------------
-- LEVEL 1 (parameter definitions, to be choosen by the composer)------------
-----------------------------------------------------------------------------

notes = ["c", "c#", "d", "d#", "e", "f", "f#", "g", "g#", "a", "a#", "b"]

major = [[0, 1, 5], [3, 4, 8], [6, 7, 11], [9, 10, 2]] -- interval-rows for computing chords
minor = [[0, 1, 4], [2, 3, 6], [5, 8, 9], [7, 10, 11]]

-- the possible entry-delays (chord duration) with corresponding minimum and maximum chord size

mapping = [("1/1", 1, 6), ("4/5", 1, 6), ("3/4", 1, 6), ("2/3", 1, 6), ("5/8", 1, 6), ("3/5", 1, 6),
           ("1/2", 1, 4), ("2/5", 1, 4), ("3/8", 1, 4), ("1/3", 1, 4),
           ("1/4", 1, 3), ("1/5", 1, 3), ("1/8", 1, 2), ("0/0", 1, 1),
           ("1/2", 1, 4), ("2/5", 1, 4), ("3/8", 1, 4), ("1/3", 1, 4),
           ("1/4", 1, 3), ("1/5", 1, 3), ("1/8", 1, 2), ("0/0", 1, 1),
           ("1/4", 1, 3), ("1/5", 1, 3), ("1/8", 1, 2), ("0/0", 1, 1),
           ("1/8", 1, 2), ("0/0", 1, 1) ]

entry_list = map f mapping where f (x,y,z) = x                -- extracted list of possible chord durations

dyna_list = ["ppp", "pp", "p", "mp", "mf", "f", "ff", "fff"]  -- possible dynamics

tempo_list = ["t60", "t52", "t45.5", "t39.5", "t34.5", "t30"] -- possible tempo values (t60 == 60 1/4-beats per minute)

-- the following process-numbers specify the type of serial generation process (see: Level 4)
-- 1..3 == Rows are generated
-- 4 == Balance structures are generated
-- 5..7 == Groups are generated

dyna_process  = 3::Int
entry_process = 4::Int
chord_process = 4::Int 

rR = 1::Int            -- 1..2, repetition rate for chord rows and groups

-- the average number of notes in a chord, caculated from the mapping above

average_chord_size = fromIntegral total / fromIntegral (2 * (length mapping))
                     where
                     total = sum [min + max | (delay, min, max) <- mapping]

-----------------------------------------------------------------------------
-- LEVEL 1 Section definition -----------------------------------------------
-----------------------------------------------------------------------------

section nlines = output dyna_str entry_str tempo_str chord_str nlines
    where
    dyna_str = d_section dynamics
                         (mk_row_str dyna_list, mk_serial_str dyna_list)
                         dyna_process
                         (length dyna_list)
    
    entry_str = d_section entry_delay
                          (mk_row_str entry_list, mk_serial_str entry_list)
                          entry_process
                          (length entry_list)

    ch_size_str = d_section chord_size
                            (flatten entry_str, [])
                            0
                            mapping

    tempo_str = d_section tempo_grp
                          (flat2 entry_str, mk_serial_str tempo_list)
                          0
                          (between 1 4)

    chord_str = d_section chord
                          (ch_size_str, mk_serial_str notes)
                          chord_process 
                          average_chord_size

-----------------------------------------------------------------------------
-- LEVEL 2 --General stream creation patterns--------------------------------
-----------------------------------------------------------------------------

d_section par_function streams process arguments =
    part : d_section par_function rest_streams process arguments
    where
    (part, rest_streams) = par_function streams process arguments

mk_row_str par_list = perm par_list : mk_row_str par_list

mk_serial_str par_list = foldr1 (++) (mk_row_str par_list)

-----------------------------------------------------------------------------
-- LEVEL 3 --Definition of the parameter functions---------------------------
-----------------------------------------------------------------------------

dynamics str_tup process par_len
    | process <= 3 = row     str_tup (round (max 1 rowMax))
    | process == 4 = balance str_tup 2 (min 8 par_len) 1
    | process >  4 = group   str_tup (between grpMin grpMax)
    where
    rowMax = fromIntegral (par_len * (5 - process)) / (fromIntegral 4)
    minvec = [[4, 6,  8], [4,  6,   8]]
    maxvec = [[6, 9, 12], [10, 15, 20]]
    grpMin = minvec !! (rR - 1) !! (process - 5)
    grpMax = maxvec !! (rR - 1) !! (process - 5)
    
entry_delay str_tup process par_len
    | process <= 3 = row str_tup (round (max 1 rowMax))
    | process == 4 = balance str_tup 1 (quot par_len 2) (between 1 4)
    | process >  4 = group str_tup (between grpMin grpMax)
    where
    rowMax = fromIntegral (par_len * (5 - process)) / (fromIntegral 4)
    minvec = [[2, 5,  8], [3,  7, 11]]
    maxvec = [[4, 8, 12], [6, 11, 16]]
    grpMin = minvec !! (rR - 1) !! (process - 5)
    grpMax = maxvec !! (rR - 1) !! (process - 5)

chord_size (delay : rest_delays, ys) process mapping =
    (Par (between min max), (rest_delays, ys))
    where
    ranges = [(min, max) | (del, min, max) <- mapping, del == delay]
    min = minimum (map fst ranges)
    max = maximum (map snd ranges)

tempo_grp (e:entries, t:tempos) process rtc = 
        if rtc == 0 then (Grp [], (e:entries, tempos))
        else             (Grp (t_list ++ rest_t_list), rest_streams)
        where
        t_list = replicate (length e) t
        (Grp rest_t_list, rest_streams) =  tempo_grp (entries, t:tempos) process (rtc - 1)

chord str_tup process average_ch_size
    | process <= 3 = row_chord str_tup (12 - (3 * (process - 1)))
    | process == 4 = balance_chord str_tup average_ch_size
    | process >  4 = one_of_3 (grp_tones str_tup (between min_tone   max_tone  )   )
                              (grp_chord str_tup (between min_group  max_group ) 3 )
                              (grp_chord str_tup (between min_dgroup max_dgroup) 6 )
    where min_tone   = process - 3
          max_tone   = min_tone * (rR + 1)
          min_group  = round ((2.0 * average_ch_size * fromIntegral (min_tone)) / 2.25)
          max_group  = min_group * (rR + 1)
          min_dgroup = round ((      average_ch_size * fromIntegral (min_tone)) / 2.25)
          max_dgroup = min_dgroup * (rR + 1)

-----------------------------------------------------------------------------
-- LEVEL 4: Row, Group and Balance of non-chord parameters-------------------
-----------------------------------------------------------------------------

row ((xs : row_str), serial_str) m = (Row (take m xs), (row_str, serial_str))

group (row_str, (x : serial_str)) m = (Grp (replicate m x), (row_str, serial_str))

balance str_tup min max repeat = (Bal set_parts (perm balance_parts), rest_streams2)
    where
        len_list                       = mk_len_list min max repeat
        proc_list                      = mk_proc_list        repeat
        set_proc_list                  = map fst proc_list
        bal_proc_list                  = map snd proc_list
        (set_parts,     rest_streams)  = struc set_proc_list str_tup      len_list
        (balance_parts, rest_streams2) = struc bal_proc_list rest_streams len_list

        struc    fs  str_tup []         = ([]            , str_tup)
        struc (f:fs) str_tup (len:lens) = ((part : parts), rest_streams2)
            where
            (part, rest_streams)   = f str_tup len
            (parts, rest_streams2) = struc fs rest_streams lens

        mk_len_list min max 0 = []
        mk_len_list min max n = between min max : mk_len_list min max (n - 1)

        mk_proc_list 0 = []
        mk_proc_list n = one_of (row, group) (group, row) : mk_proc_list (n - 1)

-----------------------------------------------------------------------------
-- LEVEL 4: row, group, double-group, tone and balance of the chord parameter
-----------------------------------------------------------------------------

row_chord (ch_len_str, note_str) row_size = (Row chords,  (rest_ch_len_str, rest_note_str))
    where
    (trio_notes, rest_note_str) = trio_row note_str
    row = take row_size trio_notes
    (chords, rest_ch_len_str) = fill_chord ch_len_str row

grp_chord (ch_len_str, note_str) ngroups group_size = (Grp chords, (rest_ch_len_str, rest_note_str))
    where
    (trio_notes, rest_note_str) = trio_row note_str
    group = take group_size trio_notes
    groups = foldr1 (++) (replicate ngroups group)
    (chords, rest_ch_len_str) = fill_chord ch_len_str groups

grp_tones (ch_len_str, note : rest_note_str) ntones = (Grp chords, (rest_ch_len_str, rest_note_str))
    where
    first_notes = note : first_notes
    (chords, rest_ch_len_str) = mk_tones ch_len_str first_notes ntones

    mk_tones               ch_len_str  first_notes 0      = ([]               ,      ch_len_str)
    mk_tones (Par ch_len : ch_len_str) first_notes ntones = (tone_sp : rest_tones, rest_ch_len_str)
        where
        (trio_notes, _)= trio_row first_notes
        chord = take ch_len trio_notes
        tone = head first_notes : tail chord
        tone_sp = foldr1 (\x y -> x ++ " " ++ y) tone
        (rest_tones, rest_ch_len_str) = mk_tones ch_len_str first_notes (ntones - 1)

balance_chord str_tup avrage_ch_size = one_of exp1 exp2
    where
    exp1 = (Bal [Row chords] [chord_grp], rest_str_tup2) where
        nrows                      = fromIntegral (between 1 3)
        ntones                     = round ((nrows * 5.0 * 2.25) / avrage_ch_size)
        ngroups                    = round ((nrows * 4.0 * 2.25) / avrage_ch_size)
        ndgroups                   = round ((nrows * 2.0 * 2.25) / avrage_ch_size)
        (chords, rest_str_tup1)    = rep_chord_row str_tup nrows
        (chord_grp, rest_str_tup2) = one_of_3  (grp_tones rest_str_tup1 ntones    )
                                               (grp_chord rest_str_tup1 ngroups 3 )
                                               (grp_chord rest_str_tup1 ndgroups 6)
    exp2 = (Bal [chords_grp] [Row chords], rest_str_tup2) where
        minElem = one_of_3 6 4 2
        maxElem = one_of_3 (18 * rR)
                           (round ((12.0 * fromIntegral (rR) * avrage_ch_size) / 2.25))
                           (round ((6.0  * fromIntegral (rR) * avrage_ch_size) / 2.25))
        nelems = between minElem maxElem
        nrows = round (fromIntegral (nelems) / (one_of_3 5.0 4.0 2.0))
        (chords_grp, rest_str_tup1) = one_of_3 (grp_tones str_tup nelems  )
                                               (grp_chord str_tup nelems 3)
                                               (grp_chord str_tup nelems 6)
        (chords, rest_str_tup2)     = rep_chord_row rest_str_tup1 nrows

-----------------------------------------------------------------------------
-- support-functions for the chord parameter functions of level 4 -----------
-----------------------------------------------------------------------------

trio_row (start_note : rest_note_str) = (map (add_note start_note) trio_list, rest_note_str)
    where
    interval_row = one_of major minor
    mixed_row    = foldr1 (++) (perm interval_row)
    trio_list    = one_of mixed_row (reverse mixed_row)

fill_chord ch_len_str row =
    if length row >= chlen then (chord_sp : rest_chords, rest_ch_len_str)
    else                        ([], ch_len_str)
    where (Par chlen : rest_lens)        = ch_len_str
          (chord, rest_row)              = splitAt chlen row
          (rest_chords, rest_ch_len_str) = fill_chord rest_lens rest_row
          chord_sp = foldr1 (\x y -> x ++ " " ++ y) chord

rep_chord_row str_tup 0     = ([], str_tup)
rep_chord_row str_tup nrows = (chords ++ rest_chords, rest_str_tup2)
    where
    (Row chords,  rest_str_tup1) = row_chord str_tup 12
    (rest_chords, rest_str_tup2) = rep_chord_row rest_str_tup1 (nrows - 1)
  
-----------------------------------------------------------------------------
-- SMALL UTILITY FUNCTIONS --------------------------------------------------
-----------------------------------------------------------------------------

select r xs = xs !! (mod r (length xs))

one_of   x y   = select 1 [x,y]
one_of_3 x y z = select 1 [x,y,z]

between left right = right

perm xs = xs

add_note note1 interval = notes !! iy
    where
    index note []     = -1
    index note (x:xs) | note == x = 0
                      | otherwise = 1 + index note xs
    ix = index note1 notes
    iy = rem (ix + interval) 12

flatten []               = []
flatten (Row x : xs)     = x ++ flatten xs
flatten (Grp x : xs)     = x ++ flatten xs
flatten (Bal xs ys : zs) = flatten xs ++ flatten ys ++ flatten zs

-- flat2 (Row x : xs)     = x : flat2 xs                       -- row structure is kept
-- flat2 (Grp x : xs)     = x : flat2 xs                       -- group structure is kept
-- flat2 (Bal xs ys : zs) = flatten xs : flatten ys : flat2 zs -- set/balance structure is kept

flat2 []               = []
flat2 (Row x : xs)     = x : flat2 xs                     -- row structure is kept
flat2 (Grp x : xs)     = x : flat2 xs                     -- group structure is kept
flat2 (Bal xs ys : zs) = flat2 xs ++ flat2 ys ++ flat2 zs -- row/group structure is kept

-----------------------------------------------------------------------------
-- OUTPUT FUNCTIONS ---------------------------------------------------------
-- one section is ouput as a table. Before each parameter the start of a new
-- row or group is marked with 'r' or 'g'. In addition the start of a balance
-- structure is marked with an 's' (set) followed later by a 'b' (balance)
-----------------------------------------------------------------------------

showP x n = replicate (n - (length str)) ' ' ++ str where str = show x

tagRow n b (x:xs) = (b ++ "r " ++ showP x n) : tagRest n xs
tagGrp n b (x:xs) = (b ++ "g " ++ showP x n) : tagRest n xs
tagPrm n b x      = ["p " ++ showP x n]
tagRest n [] = []
tagRest n (x:xs) = ("   " ++ showP x n) : tagRest n xs

tagPar n b []               = []
tagPar n b (Par x     : xs) = tagPrm n b x ++ tagPar n " " xs
tagPar n b (Row x     : xs) = tagRow n b x ++ tagPar n " " xs
tagPar n b (Grp x     : xs) = tagGrp n b x ++ tagPar n " " xs
tagPar n b (Bal xs ys : zs) = tagPar n "s" xs ++ tagPar n "b" ys ++ tagPar n b zs

output dyna_str entry_str tempo_str chord_str nlines = pr_lines (take nlines lines)
    where
    lines = pr_tagstr (tagPar 5 " " dyna_str) (tagPar 5 " " entry_str) (tagPar 7 " " tempo_str) (tagPar 1 " " chord_str)
    pr_tagstr (x:xs) (y:ys) (z:zs) (u:us) = (x ++ " |" ++ y ++ " |" ++ z ++ " |" ++ u) : pr_tagstr xs ys zs us
    pr_lines [] = []
    pr_lines (x:xs) = x ++ "\n" ++ pr_lines xs

main = putStr (section 50) -- print one section of xx lines