1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
|
module Main where
import qualified Data.List as List
data Ribbon = Ribbon [Bool] Double
deriving (Eq, Show)
newtype RawData = RawData [Ribbon]
deriving (Eq, Show)
data Limits = Limits {limitsLow :: Double, limitsHigh :: Double}
deriving (Eq, Show)
data Coord = Coord {coordX :: Double, coordY :: Double}
deriving (Eq)
instance Show Coord where
show (Coord x y) = "(" <> show x <> "," <> show y <> ")"
boolToCoords :: Limits -> Double -> Bool -> Coord
boolToCoords (Limits _ h) x True = Coord x h
boolToCoords (Limits l _) x False = Coord x l
moveX :: Double -> Coord -> Coord
moveX d (Coord x y) = Coord (x + d) y
incrX :: Double -> (Double, [Coord]) -> (Limits, Bool) -> (Double, [Coord])
incrX len (d, coords) (l, b) = (d + len, boolToCoords l d b : coords)
drawRibbon :: Double -> [Limits] -> [Bool] -> [Coord]
drawRibbon len l b =
snd $ foldl (incrX len) (0, []) $ zip l b
drawCoords :: String -> [Coord] -> String
drawCoords connection coords =
mconcat $ List.intersperse connection (show <$> coords)
inBetween :: Coord -> Coord -> Coord
inBetween (Coord x1 y1) (Coord x2 y2) =
Coord ((x1 + x2) / 2) ((y1 + y2) / 2)
condOp :: (Double -> Double) -> [Bool] -> [Double] -> [Double]
condOp f b d =
fmap condOp' $ zip b d
where
condOp' (True, d') = f d'
condOp' (False, d') = d'
condNotOp :: (Double -> Double) -> [Bool] -> [Double] -> [Double]
condNotOp f b d =
fmap condOp' $ zip b d
where
condOp' (False, d') = f d'
condOp' (True, d') = d'
drawArrow ::
Double ->
Double ->
(Int, [Double], [Double], String) ->
Ribbon ->
(Int, [Double], [Double], String)
drawArrow ratio len (it, start, end, s) (Ribbon b i) =
( it + 1,
condOp (\x -> x - i) b start,
condNotOp (\x -> x - i) b end,
s
<> "\\fill[ribbon"
<> show it
<> "] "
<> (drawCoords " to [out=0,in=180] " . reverse $ drawRibbon len upper_limit b)
<> " -- "
<> drawCoords
" -- "
[ mid1,
moveX (i * ratio) (inBetween mid1 mid2),
mid2
]
<> " -- "
<> (drawCoords " to [out=180,in=0] " $ drawRibbon len lower_limit b)
<> ";\n"
)
where
upper_limit =
fmap
( \(st, e) ->
Limits (e * ratio) (st * ratio)
)
$ zip start end
lower_limit =
fmap
( \(st, e) ->
Limits ((e - i) * ratio) ((st - i) * ratio)
)
$ zip start end
mid1 = boolToCoords (last upper_limit) ((fromIntegral $ length b) * len) (last b)
mid2 = boolToCoords (last lower_limit) ((fromIntegral $ length b) * len) (last b)
fourth :: (a, b, c, d) -> d
fourth (_, _, _, d) = d
toListLength :: [Double] -> Ribbon -> [Double]
toListLength d (Ribbon r i) =
fmap boolToDouble (zip d r)
where
boolToDouble (d', True) = d' + i
boolToDouble (d', False) = d'
initColumns :: Double -> [Ribbon] -> [Double]
initColumns d (Ribbon r _ : _) = replicate (length r) d
initColumns _ _ = []
calcMaxColumns :: [Ribbon] -> [Double]
calcMaxColumns rs = foldl toListLength (initColumns 0 rs) rs
drawRibbons :: Double -> Double -> [Ribbon] -> String
drawRibbons ratio len rs =
fourth $ foldl (drawArrow ratio len) (1, total, ends, "") rs
where
total = initColumns ((+ (0.5 / ratio)) . sum $ fmap (\(Ribbon _ d) -> d) rs) rs
ends = fmap (\(m, t) -> t - m - 0.5 / ratio) $ zip (calcMaxColumns rs) total
fpga2020 :: [Ribbon]
fpga2020 =
[ Ribbon [True, True, True, True] 15,
Ribbon [True, True, True, False] 1,
Ribbon [True, True, False, False] 6,
Ribbon [False, False, True, True] 11,
Ribbon [False, False, True, False] 1,
Ribbon [False, False, False, True] 17
]
printAll :: IO ()
printAll = putStrLn $ drawRibbons 0.05 2.0 fpga2020
main :: IO ()
main = putStrLn "Hello, Haskell!"
|
