-- | YIJING / I-CHING
module Music.Theory.Random.I_Ching where

import Control.Monad {- base -}
import Data.Maybe {- base -}
import Data.Int {- base -}
import System.Random {- random -}

import qualified Music.Theory.Bits as T {- hmt-base -}
import qualified Music.Theory.Read as T {- hmt-base -}
import qualified Music.Theory.Tuple as T {- hmt-base -}
import qualified Music.Theory.Unicode as T {- hmt-base -}

-- * LINE

-- | Line, indicated as sum.
data Line = L6 | L7 | L8 | L9 deriving (Line -> Line -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Line -> Line -> Bool
$c/= :: Line -> Line -> Bool
== :: Line -> Line -> Bool
$c== :: Line -> Line -> Bool
Eq,Int -> Line -> ShowS
[Line] -> ShowS
Line -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Line] -> ShowS
$cshowList :: [Line] -> ShowS
show :: Line -> String
$cshow :: Line -> String
showsPrec :: Int -> Line -> ShowS
$cshowsPrec :: Int -> Line -> ShowS
Show)

{-| (sum={6,7,8,9},
     (yarrow probablity={1,3,5,7}/16,
      three-coin probablity={2,6}/16,
      name,signification,symbol))
-}
type Line_Stat = (Line,(Rational,Rational,String,String,String))

-- | I-CHING chart as sequence of 4 'Line_Stat'.
i_ching_chart :: [Line_Stat]
i_ching_chart :: [Line_Stat]
i_ching_chart =
    [(Line
L6,(Rational
1forall a. Fractional a => a -> a -> a
/Rational
16,Rational
2forall a. Fractional a => a -> a -> a
/Rational
16,String
"old yin",String
"yin changing into yang",String
"---x---"))
    ,(Line
L7,(Rational
5forall a. Fractional a => a -> a -> a
/Rational
16,Rational
6forall a. Fractional a => a -> a -> a
/Rational
16,String
"young yang",String
"yang unchanging",String
"-------"))
    ,(Line
L8,(Rational
7forall a. Fractional a => a -> a -> a
/Rational
16,Rational
6forall a. Fractional a => a -> a -> a
/Rational
16,String
"young yin",String
"yin unchanging",String
"--- ---"))
    ,(Line
L9,(Rational
3forall a. Fractional a => a -> a -> a
/Rational
16,Rational
2forall a. Fractional a => a -> a -> a
/Rational
16,String
"old yang",String
"yang changing into yin",String
"---o---"))]

-- | Lines L6 and L7 are unbroken (since L6 is becoming L7).
line_unbroken :: Line -> Bool
line_unbroken :: Line -> Bool
line_unbroken Line
n = Line
n forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Line
L6,Line
L7]

-- | If /b/ then L7 else L8.
line_from_bit :: Bool -> Line
line_from_bit :: Bool -> Line
line_from_bit Bool
b = if Bool
b then Line
L7 else Line
L8

-- | Seven character ASCII string for line.
line_ascii_pp :: Line -> String
line_ascii_pp :: Line -> String
line_ascii_pp Line
n = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a. HasCallStack => String -> a
error String
"line_ascii_pp") forall a b c d e. (a, b, c, d, e) -> e
T.p5_fifth (forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Line
n [Line_Stat]
i_ching_chart)

-- | Is line (ie. sum) moving (ie. 6 or 9).
line_is_moving :: Line -> Bool
line_is_moving :: Line -> Bool
line_is_moving Line
n = Line
n forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Line
L6,Line
L9]

-- | Old yin (L6) becomes yang (L7), and old yang (L9) becomes yin (L8).
line_complement :: Line -> Maybe Line
line_complement :: Line -> Maybe Line
line_complement Line
n =
    case Line
n of
      Line
L6 -> forall a. a -> Maybe a
Just Line
L7
      Line
L9 -> forall a. a -> Maybe a
Just Line
L8
      Line
_ -> forall a. Maybe a
Nothing

{- | Sequence of sum values assigned to ascending four bit numbers.
     Sequence is in ascending probablity, ie: 1×6,3×9,5×7,7×8.

> import Music.Theory.Bits {- hmt -}
> zip (map (gen_bitseq_pp 4) [0::Int .. 15]) (map line_ascii_pp four_coin_sequence)

-}
four_coin_sequence :: [Line]
four_coin_sequence :: [Line]
four_coin_sequence =
    [Line
L6,Line
L9,Line
L9,Line
L9
    ,Line
L7,Line
L7,Line
L7,Line
L7
    ,Line
L7,Line
L8,Line
L8,Line
L8
    ,Line
L8,Line
L8,Line
L8,Line
L8]

-- * HEXAGRAM

-- | Sequence of 6 'Line'.
type Hexagram = [Line]

-- | Hexagrams are drawn upwards.
hexagram_pp :: Hexagram -> String
hexagram_pp :: [Line] -> String
hexagram_pp = [String] -> String
unlines forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a]
reverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map Line -> String
line_ascii_pp

-- | Generate hexagram (ie. sequence of six lines given by sum) using 'four_coin_sequence'.
--
-- > four_coin_gen_hexagram >>= putStrLn . hexagram_pp
four_coin_gen_hexagram :: IO Hexagram
four_coin_gen_hexagram :: IO [Line]
four_coin_gen_hexagram = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. (a -> b) -> [a] -> [b]
map ([Line]
four_coin_sequence forall a. [a] -> Int -> a
!!)) (forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
6 (forall a (m :: * -> *). (Random a, MonadIO m) => (a, a) -> m a
randomRIO (Int
0,Int
15)))

-- | 'any' of 'line_is_moving'.
hexagram_has_complement :: Hexagram -> Bool
hexagram_has_complement :: [Line] -> Bool
hexagram_has_complement = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Line -> Bool
line_is_moving

-- | If 'hexagram_has_complement' then derive it.
--
-- > h <- four_coin_gen_hexagram
-- > putStrLn (hexagram_pp h)
-- > maybe (return ()) (putStrLn . hexagram_pp) (hexagram_complement h)
hexagram_complement :: Hexagram -> Maybe Hexagram
hexagram_complement :: [Line] -> Maybe [Line]
hexagram_complement [Line]
h =
    let f :: Line -> Line
f Line
n = forall a. a -> Maybe a -> a
fromMaybe Line
n (Line -> Maybe Line
line_complement Line
n)
    in if [Line] -> Bool
hexagram_has_complement [Line]
h then forall a. a -> Maybe a
Just (forall a b. (a -> b) -> [a] -> [b]
map Line -> Line
f [Line]
h) else forall a. Maybe a
Nothing

-- | Names of hexagrams, in King Wen order (see also data/csv/combinatorics/yijing.csv)
--
-- > length hexagram_names == 64
hexagram_names :: [(String,String)]
hexagram_names :: [(String, String)]
hexagram_names =
    [(String
"乾",String
"qián")
    ,(String
"坤",String
"kūn")
    ,(String
"屯",String
"zhūn")
    ,(String
"蒙",String
"méng")
    ,(String
"需",String
"xū")
    ,(String
"訟",String
"sòng")
    ,(String
"師",String
"shī")
    ,(String
"比",String
"bǐ")
    ,(String
"小畜",String
"xiǎo chù")
    ,(String
"履",String
"lǚ")
    ,(String
"泰",String
"tài")
    ,(String
"否",String
"pǐ")
    ,(String
"同人",String
"tóng rén")
    ,(String
"大有",String
"dà yǒu")
    ,(String
"謙",String
"qiān")
    ,(String
"豫",String
"yù")
    ,(String
"隨",String
"suí")
    ,(String
"蠱",String
"gŭ")
    ,(String
"臨",String
"lín")
    ,(String
"觀",String
"guān")
    ,(String
"噬嗑",String
"shì kè")
    ,(String
"賁",String
"bì")
    ,(String
"剝",String
"bō")
    ,(String
"復",String
"fù")
    ,(String
"無妄",String
"wú wàng")
    ,(String
"大畜",String
"dà chù")
    ,(String
"頤",String
"yí")
    ,(String
"大過",String
"dà guò")
    ,(String
"坎",String
"kǎn")
    ,(String
"離",String
"lí")
    ,(String
"咸",String
"xián")
    ,(String
"恆",String
"héng")
    ,(String
"遯",String
"dùn")
    ,(String
"大壯",String
"dà zhuàng")
    ,(String
"晉",String
"jìn")
    ,(String
"明夷",String
"míng yí")
    ,(String
"家人",String
"jiā rén")
    ,(String
"睽",String
"kuí")
    ,(String
"蹇",String
"jiǎn")
    ,(String
"解",String
"xiè")
    ,(String
"損",String
"sǔn")
    ,(String
"益",String
"yì")
    ,(String
"夬",String
"guài")
    ,(String
"姤",String
"gòu")
    ,(String
"萃",String
"cuì")
    ,(String
"升",String
"shēng")
    ,(String
"困",String
"kùn")
    ,(String
"井",String
"jǐng")
    ,(String
"革",String
"gé")
    ,(String
"鼎",String
"dǐng")
    ,(String
"震",String
"zhèn")
    ,(String
"艮",String
"gèn")
    ,(String
"漸",String
"jiàn")
    ,(String
"歸妹",String
"guī mèi")
    ,(String
"豐",String
"fēng")
    ,(String
"旅",String
"lǚ")
    ,(String
"巽",String
"xùn")
    ,(String
"兌",String
"duì")
    ,(String
"渙",String
"huàn")
    ,(String
"節",String
"jié")
    ,(String
"中孚",String
"zhōng fú")
    ,(String
"小過",String
"xiǎo guò")
    ,(String
"既濟",String
"jì jì")
    ,(String
"未濟",String
"wèi jì")]

-- | Unicode hexagram characters, in King Wen order.
--
-- > import Data.List.Split {- split -}
-- > mapM_ putStrLn (chunksOf 8 hexagram_unicode_sequence)
hexagram_unicode_sequence :: [Char]
hexagram_unicode_sequence :: String
hexagram_unicode_sequence = forall a b. (a -> b) -> [a] -> [b]
map (forall a. Enum a => Int -> a
toEnum forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) Unicode_Table
T.yijing_tbl

-- | Binary form of 'Hexagram'.
hexagram_to_binary :: Hexagram -> Int8
hexagram_to_binary :: [Line] -> Int8
hexagram_to_binary = forall i. Bits i => [Bool] -> i
T.pack_bitseq forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map Line -> Bool
line_unbroken

-- | Show binary form.
hexagram_to_binary_str :: Hexagram -> String
hexagram_to_binary_str :: [Line] -> String
hexagram_to_binary_str = forall b. FiniteBits b => Int -> b -> String
T.gen_bitseq_pp Int
6 forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Line] -> Int8
hexagram_to_binary

-- | Inverse of 'hexagram_to_binary'.
hexagram_from_binary :: Int8 -> Hexagram
hexagram_from_binary :: Int8 -> [Line]
hexagram_from_binary = forall a b. (a -> b) -> [a] -> [b]
map Bool -> Line
line_from_bit forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b. FiniteBits b => Int -> b -> [Bool]
T.gen_bitseq Int
6

-- | Read binary form.
--
-- > let h = hexagram_from_binary_str "100010"
-- > putStrLn (hexagram_pp h)
-- > hexagram_to_binary_str h == "100010"
hexagram_from_binary_str :: String -> Hexagram
hexagram_from_binary_str :: String -> [Line]
hexagram_from_binary_str = Int8 -> [Line]
hexagram_from_binary forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Integral a => String -> a
T.read_bin_err

-- * TRIGRAM

-- | Unicode sequence of trigrams (unicode order).
--
-- > import Data.List {- base -}
-- > putStrLn (intersperse ' ' trigram_unicode_sequence)
trigram_unicode_sequence :: [Char]
trigram_unicode_sequence :: String
trigram_unicode_sequence = forall a b. (a -> b) -> [a] -> [b]
map (forall a. Enum a => Int -> a
toEnum forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) Unicode_Table
T.bagua_tbl

-- | (INDEX,UNICODE,BIT-SEQUENCE,NAME,NAME-TRANSLITERATION,NATURE-IMAGE,DIRECTION,ANIMAL)
--
-- > map (T.read_bin_err . T.p8_third) trigram_chart == [7,6,5,4,3,2,1,0]
trigram_chart :: [(Int, Char, String, Char, String, Char, String, Char)]
trigram_chart :: [(Int, Char, String, Char, String, Char, String, Char)]
trigram_chart =
    [(Int
1,Char
'☰',String
"111",Char
'乾',String
"qián",Char
'天',String
"NW",Char
'馬')
    ,(Int
2,Char
'☱',String
"110",Char
'兌',String
"duì",Char
'澤',String
"W",Char
'羊')
    ,(Int
3,Char
'☲',String
"101",Char
'離',String
"lí",Char
'火',String
"S",Char
'雉')
    ,(Int
4,Char
'☳',String
"100",Char
'震',String
"zhèn",Char
'雷',String
"E",Char
'龍')
    ,(Int
5,Char
'☴',String
"011",Char
'巽',String
"xùn",Char
'風',String
"SE",Char
'雞')
    ,(Int
6,Char
'☵',String
"010",Char
'坎',String
"kǎn",Char
'水',String
"N",Char
'豕')
    ,(Int
7,Char
'☶',String
"001",Char
'艮',String
"gèn",Char
'山',String
"NE",Char
'狗')
    ,(Int
8,Char
'☷',String
"000",Char
'坤',String
"kūn",Char
'地',String
"SW",Char
'牛')]