module GrayCode where

import Midi ;
import Pitch ;
import Tuple ;
import List () ;
import Bool (ifThenElse) ;
import ListLive ;
import Prelude hiding (fst, snd) ;


main :: [ Event (Channel Message) ] ;
main :: [Event (Channel Message)]
main =
   Integer -> [Event Message] -> [Event (Channel Message)]
forall a. Integer -> [Event a] -> [Event (Channel a)]
channel Integer
0 ([Event Message] -> [Event (Channel Message)])
-> [Event Message] -> [Event (Channel Message)]
forall a b. (a -> b) -> a -> b
$ Integer -> [Event Message] -> [Event Message]
forall a. Integer -> [Event a] -> [Event a]
changeTempo Integer
timeUnit ([Event Message] -> [Event Message])
-> [Event Message] -> [Event Message]
forall a b. (a -> b) -> a -> b
$ [Event Message] -> [Event Message]
forall a. HasCallStack => [a] -> [a]
cycle [Event Message]
overlapping ;

shortChords, overlapping :: [ Event Message ] ;
shortChords :: [Event Message]
shortChords =
   ([Bool] -> [Event Message]) -> [[Bool]] -> [Event Message]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap [Bool] -> [Event Message]
chordFromCode ([[Bool]] -> [Event Message]) -> [[Bool]] -> [Event Message]
forall a b. (a -> b) -> a -> b
$ Integer -> [[Bool]]
grayCodes Integer
4 ;

chordFromCode :: [ Bool ] -> [ Event Message ] ;
chordFromCode :: [Bool] -> [Event Message]
chordFromCode [Bool]
bits =
   ([Bool] -> [Event Message] -> [Event Message]
forall a. [Bool] -> [a] -> [a]
filterWith [Bool]
bits ([Event Message] -> [Event Message])
-> [Event Message] -> [Event Message]
forall a b. (a -> b) -> a -> b
$ (Integer -> Event Message) -> [Integer] -> [Event Message]
forall a b. (a -> b) -> [a] -> [b]
map Integer -> Event Message
noteOn [Integer]
pitches)
   [Event Message] -> [Event Message] -> [Event Message]
forall a. [a] -> [a] -> [a]
++
   Integer -> Event Message
forall a. Integer -> Event a
Wait Integer
qn
   Event Message -> [Event Message] -> [Event Message]
forall a. a -> [a] -> [a]
:
   ([Bool] -> [Event Message] -> [Event Message]
forall a. [Bool] -> [a] -> [a]
filterWith [Bool]
bits ([Event Message] -> [Event Message])
-> [Event Message] -> [Event Message]
forall a b. (a -> b) -> a -> b
$ (Integer -> Event Message) -> [Integer] -> [Event Message]
forall a b. (a -> b) -> [a] -> [b]
map Integer -> Event Message
noteOff [Integer]
pitches) ;

filterWith :: [ Bool ] -> [ a ] -> [ a ] ;
filterWith :: forall a. [Bool] -> [a] -> [a]
filterWith [Bool]
bits =
   (Pair Bool a -> a) -> [Pair Bool a] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map Pair Bool a -> a
forall a b. Pair a b -> b
snd ([Pair Bool a] -> [a]) -> ([a] -> [Pair Bool a]) -> [a] -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Pair Bool a -> Bool) -> [Pair Bool a] -> [Pair Bool a]
forall a. (a -> Bool) -> [a] -> [a]
filter Pair Bool a -> Bool
forall a b. Pair a b -> a
fst ([Pair Bool a] -> [Pair Bool a])
-> ([a] -> [Pair Bool a]) -> [a] -> [Pair Bool a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bool -> a -> Pair Bool a) -> [Bool] -> [a] -> [Pair Bool a]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Bool -> a -> Pair Bool a
forall a b. a -> b -> Pair a b
Pair [Bool]
bits ;


overlapping :: [Event Message]
overlapping =
   (Event Message -> [Event Message])
-> [Event Message] -> [Event Message]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Event Message -> [Event Message] -> [Event Message]
forall a. a -> [a] -> [a]
cons (Integer -> Event Message
forall a. Integer -> Event a
Wait Integer
qn) ([Event Message] -> [Event Message])
-> (Event Message -> [Event Message])
-> Event Message
-> [Event Message]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Event Message -> [Event Message] -> [Event Message])
-> [Event Message] -> Event Message -> [Event Message]
forall a b c. (a -> b -> c) -> b -> a -> c
flip Event Message -> [Event Message] -> [Event Message]
forall a. a -> [a] -> [a]
cons []) ([Event Message] -> [Event Message])
-> [Event Message] -> [Event Message]
forall a b. (a -> b) -> a -> b
$
   (Bool -> Integer -> Event Message) -> Integer -> [Event Message]
forall a. (Bool -> Integer -> a) -> Integer -> [a]
grayChanges Bool -> Integer -> Event Message
makeNoteOnOff Integer
4 ;

makeNoteOnOff :: Bool -> Integer -> Event Message ;
makeNoteOnOff :: Bool -> Integer -> Event Message
makeNoteOnOff Bool
bl Integer
n =
   Bool
-> (Integer -> Event Message)
-> (Integer -> Event Message)
-> Integer
-> Event Message
forall a. Bool -> a -> a -> a
ifThenElse Bool
bl Integer -> Event Message
noteOn Integer -> Event Message
noteOff (Integer -> Event Message) -> Integer -> Event Message
forall a b. (a -> b) -> a -> b
$ Integer -> Integer
makePitch Integer
n ;

pitches :: [ Pitch ] ;
pitches :: [Integer]
pitches = (Integer -> Integer) -> [Integer] -> [Integer]
forall a b. (a -> b) -> [a] -> [b]
map Integer -> Integer
makePitch ([Integer] -> [Integer]) -> [Integer] -> [Integer]
forall a b. (a -> b) -> a -> b
$ Integer -> [Integer]
forall a. Enum a => a -> [a]
enumFrom Integer
0 ;

makePitch :: Integer -> Pitch ;
makePitch :: Integer -> Integer
makePitch Integer
0 = Integer -> Integer
c Integer
4 ;
makePitch Integer
1 = Integer -> Integer
e Integer
4 ;
makePitch Integer
2 = Integer -> Integer
g Integer
4 ;
makePitch Integer
_ = Integer -> Integer
c Integer
5 ;


-- * Enumerate binary codes

{- |
Enumerate binary codes where only one bit changes between adjacent codes.
-}
grayCodes :: Integer -> [[Bool]] ;
grayCodes :: Integer -> [[Bool]]
grayCodes Integer
0 = [[]] ;
grayCodes Integer
n =
   ([Bool] -> [Bool]) -> [[Bool]] -> [[Bool]]
forall a b. (a -> b) -> [a] -> [b]
map (Bool -> [Bool] -> [Bool]
forall a. a -> [a] -> [a]
cons Bool
False) (Integer -> [[Bool]]
grayCodes (Integer
nInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
1)) [[Bool]] -> [[Bool]] -> [[Bool]]
forall a. [a] -> [a] -> [a]
++
   ([Bool] -> [Bool]) -> [[Bool]] -> [[Bool]]
forall a b. (a -> b) -> [a] -> [b]
map (Bool -> [Bool] -> [Bool]
forall a. a -> [a] -> [a]
cons Bool
True) ([[Bool]] -> [[Bool]]
forall a. [a] -> [a]
reverse ([[Bool]] -> [[Bool]]) -> [[Bool]] -> [[Bool]]
forall a b. (a -> b) -> a -> b
$ Integer -> [[Bool]]
grayCodes (Integer
nInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
1)) ;


{- |
Positions that change in the gray code
bundled with the bit value after the change.
-}
grayChanges :: (Bool -> Integer -> a) -> Integer -> [a] ;
grayChanges :: forall a. (Bool -> Integer -> a) -> Integer -> [a]
grayChanges Bool -> Integer -> a
mk Integer
n =
   (Bool -> Integer -> a) -> Bool -> Integer -> [a]
forall a. (Bool -> Integer -> a) -> Bool -> Integer -> [a]
grayChangesRec Bool -> Integer -> a
mk Bool
True Integer
n [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [Bool -> Integer -> a
mk Bool
False Integer
n] ;

grayChangesRec :: (Bool -> Integer -> a) -> Bool -> Integer -> [a] ;
grayChangesRec :: forall a. (Bool -> Integer -> a) -> Bool -> Integer -> [a]
grayChangesRec Bool -> Integer -> a
_mk Bool
_bl Integer
0 = [] ;
grayChangesRec Bool -> Integer -> a
mk Bool
bl Integer
n =
   (Bool -> Integer -> a) -> Bool -> Integer -> [a]
forall a. (Bool -> Integer -> a) -> Bool -> Integer -> [a]
grayChangesRec Bool -> Integer -> a
mk Bool
True  (Integer
nInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
1) [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++
   Bool -> Integer -> a
mk Bool
bl (Integer
nInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
1) a -> [a] -> [a]
forall a. a -> [a] -> [a]
:
   (Bool -> Integer -> a) -> Bool -> Integer -> [a]
forall a. (Bool -> Integer -> a) -> Bool -> Integer -> [a]
grayChangesRec Bool -> Integer -> a
mk Bool
False (Integer
nInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
1) ;


-- * auxiliary

timeUnit :: Time ;
timeUnit :: Integer
timeUnit = Integer
150 ;

qn :: Integer ;
qn :: Integer
qn = Integer
1 ;