-- | <http://en.wikipedia.org/wiki/Braille_Patterns>
module Music.Theory.Braille where

import Data.Char {- base -}
import Data.List {- base -}
import Data.Maybe {- base -}
import Text.Printf {- base -}

-- | Braille coding data.  Elements are: (ASCII HEX,ASCII CHAR,DOT
-- LIST,UNICODE CHAR,MEANING).  The dot numbers are in column order.
type BRAILLE = (Int,Char,[Int],Char,String)

-- | ASCII 'Char' of 'BRAILLE'.
braille_ascii :: BRAILLE -> Char
braille_ascii :: BRAILLE -> Char
braille_ascii (Int
_,Char
c,[Int]
_,Char
_,String
_) = Char
c

-- | Unicode 'Char' of 'BRAILLE'.
braille_unicode :: BRAILLE -> Char
braille_unicode :: BRAILLE -> Char
braille_unicode (Int
_,Char
_,[Int]
_,Char
c,String
_) = Char
c

-- | Dot list of 'BRAILLE'.
braille_dots :: BRAILLE -> [Int]
braille_dots :: BRAILLE -> [Int]
braille_dots (Int
_,Char
_,[Int]
d,Char
_,String
_) = [Int]
d

-- | ASCII Braille table.
--
-- > all id (map (\(x,c,_,_,_) -> x == fromEnum c) braille_table) == True
braille_table :: [BRAILLE]
braille_table :: [BRAILLE]
braille_table =
    [(Int
0x20,Char
' ',[],Char
'⠀',String
" ")
    ,(Int
0x21,Char
'!',[Int
2,Int
3,Int
4,Int
6],Char
'⠮',String
"the")
    ,(Int
0x22,Char
'"',[Int
5],Char
'⠐',String
"contraction")
    ,(Int
0x23,Char
'#',[Int
3,Int
4,Int
5,Int
6],Char
'⠼',String
"number prefix")
    ,(Int
0x24,Char
'$',[Int
1,Int
2,Int
4,Int
6],Char
'⠫',String
"ed")
    ,(Int
0x25,Char
'%',[Int
1,Int
4,Int
6],Char
'⠩',String
"sh")
    ,(Int
0x26,Char
'&',[Int
1,Int
2,Int
3,Int
4,Int
6],Char
'⠯',String
"and")
    ,(Int
0x27,Char
'\'',[Int
3],Char
'⠄',String
"'")
    ,(Int
0x28,Char
'(',[Int
1,Int
2,Int
3,Int
5,Int
6],Char
'⠷',String
"of")
    ,(Int
0x29,Char
')',[Int
2,Int
3,Int
4,Int
5,Int
6],Char
'⠾',String
"with")
    ,(Int
0x2A,Char
'*',[Int
1,Int
6],Char
'⠡',String
"ch")
    ,(Int
0x2B,Char
'+',[Int
3,Int
4,Int
6],Char
'⠬',String
"ing")
    ,(Int
0x2C,Char
',',[Int
6],Char
'⠠',String
"uppercase prefix")
    ,(Int
0x2D,Char
'-',[Int
3,Int
6],Char
'⠤',String
"-")
    ,(Int
0x2E,Char
'.',[Int
4,Int
6],Char
'⠨',String
"italic prefix")
    ,(Int
0x2F,Char
'/',[Int
3,Int
4],Char
'⠌',String
"st")
    ,(Int
0x30,Char
'0',[Int
3,Int
5,Int
6],Char
'⠴',String
"”")
    ,(Int
0x31,Char
'1',[Int
2],Char
'⠂',String
",")
    ,(Int
0x32,Char
'2',[Int
2,Int
3],Char
'⠆',String
";")
    ,(Int
0x33,Char
'3',[Int
2,Int
5],Char
'⠒',String
":")
    ,(Int
0x34,Char
'4',[Int
2,Int
5,Int
6],Char
'⠲',String
".")
    ,(Int
0x35,Char
'5',[Int
2,Int
6],Char
'⠢',String
"en")
    ,(Int
0x36,Char
'6',[Int
2,Int
3,Int
5],Char
'⠖',String
"!")
    ,(Int
0x37,Char
'7',[Int
2,Int
3,Int
5,Int
6],Char
'⠶',String
"( or )")
    ,(Int
0x38,Char
'8',[Int
2,Int
3,Int
6],Char
'⠦',String
"“ or ?")
    ,(Int
0x39,Char
'9',[Int
3,Int
5],Char
'⠔',String
"in")
    ,(Int
0x3A,Char
':',[Int
1,Int
5,Int
6],Char
'⠱',String
"wh")
    ,(Int
0x3B,Char
';',[Int
5,Int
6],Char
'⠰',String
"letter prefix")
    ,(Int
0x3C,Char
'<',[Int
1,Int
2,Int
6],Char
'⠣',String
"gh")
    ,(Int
0x3D,Char
'=',[Int
1,Int
2,Int
3,Int
4,Int
5,Int
6],Char
'⠿',String
"for")
    ,(Int
0x3E,Char
'>',[Int
3,Int
4,Int
5],Char
'⠜',String
"ar")
    ,(Int
0x3F,Char
'?',[Int
1,Int
4,Int
5,Int
6],Char
'⠹',String
"th")
    ,(Int
0x40,Char
'@',[Int
4],Char
'⠈',String
"accent prefix")
    ,(Int
0x41,Char
'A',[Int
1],Char
'⠁',String
"a")
    ,(Int
0x42,Char
'B',[Int
1,Int
2],Char
'⠃',String
"b")
    ,(Int
0x43,Char
'C',[Int
1,Int
4],Char
'⠉',String
"c")
    ,(Int
0x44,Char
'D',[Int
1,Int
4,Int
5],Char
'⠙',String
"d")
    ,(Int
0x45,Char
'E',[Int
1,Int
5],Char
'⠑',String
"e")
    ,(Int
0x46,Char
'F',[Int
1,Int
2,Int
4],Char
'⠋',String
"f")
    ,(Int
0x47,Char
'G',[Int
1,Int
2,Int
4,Int
5],Char
'⠛',String
"g")
    ,(Int
0x48,Char
'H',[Int
1,Int
2,Int
5],Char
'⠓',String
"h")
    ,(Int
0x49,Char
'I',[Int
2,Int
4],Char
'⠊',String
"i")
    ,(Int
0x4A,Char
'J',[Int
2,Int
4,Int
5],Char
'⠚',String
"j")
    ,(Int
0x4B,Char
'K',[Int
1,Int
3],Char
'⠅',String
"k")
    ,(Int
0x4C,Char
'L',[Int
1,Int
2,Int
3],Char
'⠇',String
"l")
    ,(Int
0x4D,Char
'M',[Int
1,Int
3,Int
4],Char
'⠍',String
"m")
    ,(Int
0x4E,Char
'N',[Int
1,Int
3,Int
4,Int
5],Char
'⠝',String
"n")
    ,(Int
0x4F,Char
'O',[Int
1,Int
3,Int
5],Char
'⠕',String
"o")
    ,(Int
0x50,Char
'P',[Int
1,Int
2,Int
3,Int
4],Char
'⠏',String
"p")
    ,(Int
0x51,Char
'Q',[Int
1,Int
2,Int
3,Int
4,Int
5],Char
'⠟',String
"q")
    ,(Int
0x52,Char
'R',[Int
1,Int
2,Int
3,Int
5],Char
'⠗',String
"r")
    ,(Int
0x53,Char
'S',[Int
2,Int
3,Int
4],Char
'⠎',String
"s")
    ,(Int
0x54,Char
'T',[Int
2,Int
3,Int
4,Int
5],Char
'⠞',String
"t")
    ,(Int
0x55,Char
'U',[Int
1,Int
3,Int
6],Char
'⠥',String
"u")
    ,(Int
0x56,Char
'V',[Int
1,Int
2,Int
3,Int
6],Char
'⠧',String
"v")
    ,(Int
0x57,Char
'W',[Int
2,Int
4,Int
5,Int
6],Char
'⠺',String
"w")
    ,(Int
0x58,Char
'X',[Int
1,Int
3,Int
4,Int
6],Char
'⠭',String
"x")
    ,(Int
0x59,Char
'Y',[Int
1,Int
3,Int
4,Int
5,Int
6],Char
'⠽',String
"y")
    ,(Int
0x5A,Char
'Z',[Int
1,Int
3,Int
5,Int
6],Char
'⠵',String
"z")
    ,(Int
0x5B,Char
'[',[Int
2,Int
4,Int
6],Char
'⠪',String
"ow")
    ,(Int
0x5C,Char
'\\',[Int
1,Int
2,Int
5,Int
6],Char
'⠳',String
"ou")
    ,(Int
0x5D,Char
']',[Int
1,Int
2,Int
4,Int
5,Int
6],Char
'⠻',String
"er")
    ,(Int
0x5E,Char
'^',[Int
4,Int
5],Char
'⠘',String
"currency prefix")
    ,(Int
0x5F,Char
'_',[Int
4,Int
5,Int
6],Char
'⠸',String
"contraction")
    ]

-- | Lookup 'BRAILLE' value for unicode character.
--
-- > braille_lookup_unicode '⠝' == Just (0x4E,'N',[1,3,4,5],'⠝',"n")
braille_lookup_unicode :: Char -> Maybe BRAILLE
braille_lookup_unicode :: Char -> Maybe BRAILLE
braille_lookup_unicode Char
c = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((forall a. Eq a => a -> a -> Bool
== Char
c) forall b c a. (b -> c) -> (a -> b) -> a -> c
. BRAILLE -> Char
braille_unicode) [BRAILLE]
braille_table

-- | Lookup 'BRAILLE' value for ascii character (case invariant).
--
-- > braille_lookup_ascii 'N' == Just (0x4E,'N',[1,3,4,5],'⠝',"n")
braille_lookup_ascii :: Char -> Maybe BRAILLE
braille_lookup_ascii :: Char -> Maybe BRAILLE
braille_lookup_ascii Char
c = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((forall a. Eq a => a -> a -> Bool
== Char -> Char
toUpper Char
c) forall b c a. (b -> c) -> (a -> b) -> a -> c
. BRAILLE -> Char
braille_ascii) [BRAILLE]
braille_table

-- | The arrangement of the 6-dot patterns into /decades/, sequences
-- of (1,10,3) cells.  The cell to the left of the decade is the empty
-- cell, the two cells to the right are the first two cells of the
-- decade shifted right.
--
-- For each decade there are two extra cells that shift
-- the first two cells of the decade right one place.  Subsequent
-- decades are derived by simple transformation of the first.  The
-- second is the first with the addition of dot @3@, the third adds
-- dots @3@ and @6@, the fourth adds dot @6@ and the fifth shifts the
-- first down one row.
--
-- The first decade has the 13 of the 16 4-dot patterns, the remaining
-- 3 are in the fifth decade, that is they are the three 4-dot
-- patterns that are down shifts of a 4-dot pattern.
--
-- > let trimap f (p,q,r) = (f p,f q,f r)
-- > let f = map (fromJust . decode) in map (trimap f) braille_64
braille_64 :: [(String,String,String)]
braille_64 :: [(String, String, String)]
braille_64 =
    [(String
"⠀",String
"⠁⠃⠉⠙⠑⠋⠛⠓⠊⠚",String
"⠈⠘")
    ,(String
"⠄",String
"⠅⠇⠍⠝⠕⠏⠟⠗⠎⠞",String
"⠌⠜")
    ,(String
"⠤",String
"⠥⠧⠭⠽⠵⠯⠿⠷⠮⠾",String
"⠬⠼")
    ,(String
"⠠",String
"⠡⠣⠩⠹⠱⠫⠻⠳⠪⠺",String
"⠨⠸")
    ,(String
"",String
"⠂⠆⠒⠲⠢⠖⠶⠦⠔⠴",String
"⠐⠰")]

-- | Transcribe ASCII to unicode braille.
--
-- > transcribe_unicode "BRAILLE ASCII CHAR GRID" == "⠃⠗⠁⠊⠇⠇⠑⠀⠁⠎⠉⠊⠊⠀⠉⠓⠁⠗⠀⠛⠗⠊⠙"
-- > transcribe_unicode "BRAILLE HTML TABLE GRID" == "⠃⠗⠁⠊⠇⠇⠑⠀⠓⠞⠍⠇⠀⠞⠁⠃⠇⠑⠀⠛⠗⠊⠙"
transcribe_unicode :: String -> String
transcribe_unicode :: String -> String
transcribe_unicode = forall a b. (a -> b) -> [a] -> [b]
map (BRAILLE -> Char
braille_unicode forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. HasCallStack => Maybe a -> a
fromJust forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Maybe BRAILLE
braille_lookup_ascii)

-- | Generate a character grid using inidicated values for filled and empty cells.
--
-- > let ch = (' ','.')
-- > putStrLn$ transcribe_char_grid ch "BRAILLE ASCII CHAR GRID"
--
-- > let ch = (white_circle,black_circle)
-- > putStrLn$ string_html_table $ transcribe_char_grid ch "BRAILLE HTML TABLE GRID"
transcribe_char_grid :: (Char,Char) -> String -> String
transcribe_char_grid :: (Char, Char) -> String -> String
transcribe_char_grid (Char
w,Char
b) =
    [String] -> String
unlines forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    forall a b. (a -> b) -> [a] -> [b]
map forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    forall a. [[a]] -> [[a]]
transpose forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    forall a b. (a -> b) -> [a] -> [b]
map (forall c. (c, c) -> [Int] -> [[c]]
dots_grid (Char
w,Char
b) forall b c a. (b -> c) -> (a -> b) -> a -> c
. BRAILLE -> [Int]
braille_dots forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. HasCallStack => Maybe a -> a
fromJust forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Maybe BRAILLE
braille_lookup_ascii)

-- | Generate 6-dot grid given (white,black) values.
--
-- > dots_grid (0,1) [1,2,3,5] == [[1,0],[1,1],[1,0]]
dots_grid :: (c,c) -> [Int] -> [[c]]
dots_grid :: forall c. (c, c) -> [Int] -> [[c]]
dots_grid (c
w,c
b) [Int]
d =
    let f :: Int -> c
f Int
n = if Int
n forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Int]
d then c
b else c
w
    in forall a b. (a -> b) -> [a] -> [b]
map (forall a b. (a -> b) -> [a] -> [b]
map Int -> c
f) [[Int
1,Int
4],[Int
2,Int
5],[Int
3,Int
6]]

-- | 'lines' as rows and 'Char' as cells in HTML table.
string_html_table :: String -> String
string_html_table :: String -> String
string_html_table String
s =
    let f :: Char -> String
f Char
x = String
"<td>" forall a. [a] -> [a] -> [a]
++ [Char
x] forall a. [a] -> [a] -> [a]
++ String
"</td>"
        g :: t Char -> String
g t Char
x = String
"<tr>" forall a. [a] -> [a] -> [a]
++ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Char -> String
f t Char
x forall a. [a] -> [a] -> [a]
++ String
"</tr>"
        h :: t (t Char) -> String
h t (t Char)
x = String
"<table>" forall a. [a] -> [a] -> [a]
++ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall {t :: * -> *}. Foldable t => t Char -> String
g t (t Char)
x forall a. [a] -> [a] -> [a]
++ String
"</table>"
    in forall {t :: * -> *} {t :: * -> *}.
(Foldable t, Foldable t) =>
t (t Char) -> String
h (String -> [String]
lines String
s)

{- | Decoding.

> let t0 = ["⠠⠁⠇⠇⠀⠓⠥⠍⠁⠝⠀⠆⠬⠎⠀⠜⠑⠀⠃⠕⠗⠝⠀⠋⠗⠑⠑⠀⠯⠀⠑⠟⠥⠁⠇⠀⠔⠀⠙⠊⠛⠝⠰⠽⠀⠯⠀⠐⠗⠎⠲"
>          ,"⠠⠮⠽⠀⠜⠑⠀⠢⠙⠪⠫⠀⠾⠀⠗⠂⠎⠕⠝⠀⠯⠀⠒⠎⠉⠊⠰⠑⠀⠯⠀⠩⠙⠀⠁⠉⠞⠀⠞⠪⠜⠙⠎⠀⠐⠕⠀⠁⠝⠕⠤"
>          ,"⠮⠗⠀⠔⠀⠁⠀⠸⠎⠀⠷⠀⠃⠗⠕⠮⠗⠓⠕⠕⠙⠲"]

> concatMap (fromMaybe "#" . decode) (concat t0)

-}
decode :: Char -> Maybe String
decode :: Char -> Maybe String
decode Char
c =
    case Char -> Maybe BRAILLE
braille_lookup_unicode Char
c of
      Just (Int
_,Char
_,[Int]
_,Char
_,String
s) -> forall a. a -> Maybe a
Just String
s
      Maybe BRAILLE
Nothing -> forall a. Maybe a
Nothing

-- | Start and end unicode indices.
braille_rng :: Integral i => (i,i)
braille_rng :: forall i. Integral i => (i, i)
braille_rng = (i
0x2800,i
0x28FF)

-- | All characters, in sequence.
--
-- > length braille_seq == 256
-- > putStrLn braille_seq
braille_seq :: [Char]
braille_seq :: String
braille_seq = let (Int
l,Int
r) = forall i. Integral i => (i, i)
braille_rng in [forall a. Enum a => Int -> a
toEnum Int
l .. forall a. Enum a => Int -> a
toEnum Int
r]

-- | The /n/th character, zero indexed.
braille_char :: Int -> Char
braille_char :: Int -> Char
braille_char = forall a. Enum a => Int -> a
toEnum forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Num a => a -> a -> a
(+) Int
0x2800

-- | Two element index, 255 * 255 = 65025 places.
--
-- > map braille_ix [100,300]
braille_ix :: Int -> (Char,Char)
braille_ix :: Int -> (Char, Char)
braille_ix Int
n =
    let (Int
i,Int
j) = Int
n forall a. Integral a => a -> a -> (a, a)
`divMod` Int
255
        f :: Int -> Char
f Int
k = Int -> Char
braille_char (Int
k forall a. Num a => a -> a -> a
+ Int
1)
    in (Int -> Char
f Int
i,Int -> Char
f Int
j)

-- | HTML character encoding (as hex integer).
--
-- > unwords $ map unicode_html braille_seq
unicode_html :: Char -> String
unicode_html :: Char -> String
unicode_html = forall r. PrintfType r => String -> r
printf String
"&#x%x;" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Enum a => a -> Int
fromEnum

-- * Unicode

-- | White (empty) circle.
white_circle :: Char
white_circle :: Char
white_circle = Char
'○'

-- | Black (filled) circle.
black_circle :: Char
black_circle :: Char
black_circle = Char
'●'

-- | Shaded (hatched) circle.
shaded_circle :: Char
shaded_circle :: Char
shaded_circle = Char
'◍'

-- * Contractions

-- | Table of one letter contractions.
one_letter_contractions :: [(Char,String)]
one_letter_contractions :: [(Char, String)]
one_letter_contractions =
    [(Char
'⠃',String
"but")
    ,(Char
'⠉',String
"can")
    ,(Char
'⠙',String
"do")
    ,(Char
'⠑',String
"every")
    ,(Char
'⠋',String
"from,-self")
    ,(Char
'⠛',String
"go")
    ,(Char
'⠓',String
"have")
    ,(Char
'⠚',String
"just")
    ,(Char
'⠅',String
"knowledge")
    ,(Char
'⠇',String
"like")
    ,(Char
'⠍',String
"more")
    ,(Char
'⠝',String
"not")
    ,(Char
'⠏',String
"people")
    ,(Char
'⠟',String
"quite")
    ,(Char
'⠗',String
"rather")
    ,(Char
'⠎',String
"so")
    ,(Char
'⠞',String
"that")
    ,(Char
'⠌',String
"still")
    ,(Char
'⠥',String
"us")
    ,(Char
'⠧',String
"very")
    ,(Char
'⠭',String
"it")
    ,(Char
'⠽',String
"you")
    ,(Char
'⠵',String
"as")
    ,(Char
'⠡',String
"child")
    ,(Char
'⠩',String
"shall")
    ,(Char
'⠹',String
"this")
    ,(Char
'⠱',String
"which")
    ,(Char
'⠳',String
"out")
    ,(Char
'⠺',String
"will")
    ,(Char
'⠆',String
"be,be-")
    ,(Char
'⠒',String
"con-")
    ,(Char
'⠲',String
"dis-")
    ,(Char
'⠢',String
"enough")
    ,(Char
'⠖',String
"to")
    ,(Char
'⠶',String
"were")
    ,(Char
'⠦',String
"his")
    ,(Char
'⠔',String
"in")
    ,(Char
'⠴',String
"by,was")
    ,(Char
'⠤',String
"com-")
    ]