module Music.Theory.Random.I_Ching where
import Control.Monad
import Data.Maybe
import Data.Int
import System.Random
import qualified Music.Theory.Bits as T
import qualified Music.Theory.Read as T
import qualified Music.Theory.Tuple as T
import qualified Music.Theory.Unicode as T
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)
type Line_Stat = (Line,(Rational,Rational,String,String,String))
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---"))]
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]
line_from_bit :: Bool -> Line
line_from_bit :: Bool -> Line
line_from_bit Bool
b = if Bool
b then Line
L7 else Line
L8
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)
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]
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
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]
type Hexagram = [Line]
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
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)))
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
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
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ì")]
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
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
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
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
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 :: [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
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
'牛')]