1 /** This file is part of Shapes.
3 ** Shapes is free software: you can redistribute it and/or modify
4 ** it under the terms of the GNU General Public License as published by
5 ** the Free Software Foundation, either version 3 of the License, or
8 ** Shapes is distributed in the hope that it will be useful,
9 ** but WITHOUT ANY WARRANTY; without even the implied warranty of
10 ** MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
11 ** GNU General Public License for more details.
13 ** You should have received a copy of the GNU General Public License
14 ** along with Shapes. If not, see <http://www.gnu.org/licenses/>.
16 ** Copyright 2008, 2010, 2014, 2015 Henrik Tidefelt
19 ##needs ..Shapes..Layout / shiftoff
20 ##needs ..Shapes..Layout / centering-X
21 ##needs ..Shapes..Graphics / arrowheads
24 ##lookin ..Shapes..Layout
26 dynamic @longblockrx identity 0.7cm
27 dynamic @longblockry identity 0.4cm
28 dynamic @smallblockr identity 0.3cm
29 dynamic @fracblockry identity 0.5cm
31 dynamic @connectionlw identity 0.8bp
32 dynamic @blocklw identity 0.8bp
34 dynamic @abovelabelmargin identity 1.5mm
35 dynamic @belowlabelmargin identity 1.5mm
36 dynamic @leftrightlabelmargin identity 1mm
37 dynamic @signmarginslide identity 1.5mm
38 dynamic @signmarginoffset identity 2mm
40 dynamic @blockspaceverynear identity 3mm
41 dynamic @blockspacenear identity 6mm
42 dynamic @blockspacelabelspace identity 8mm
43 dynamic @blockspacefar identity 10mm
44 dynamic @blockspaceveryfar identity 15mm
46 dynamic @textscaling identity [scale 1]
48 dynamic @connectpainter identity [Graphics..stroke head:Graphics..ShapesArrow ...]
49 dynamic @blockpainter identity stroke
51 centerlabel: \ obj → [Layout..center_x [Xcenter_y obj]]
53 putlabelAbove: \ lbl z x → [[shift z + (0cm,@abovelabelmargin)] [Layout..center_x lbl x]]
54 putlabelBelow: \ lbl z x → [[shift z + (0cm,~@belowlabelmargin)] [Xcenter_y [Layout..center_x lbl x] 1]]
55 putlabelLeft: \ lbl z y → [[shift z + (~@leftrightlabelmargin,0cm)] [Xcenter_y [Layout..center_x lbl 1] y]]
56 putlabelRight: \ lbl z y → [[shift z + (@leftrightlabelmargin,0cm)] [Xcenter_y lbl y]]
57 leftpointsign: \ obj str n:1 i:1 → [[shift [leftpoint obj n i] + (~@signmarginslide,~@signmarginoffset)] [center [Graphics..TeX [String..sprintf `$\scriptsize %s$´ str]] (0,0)]]
58 rightpointsign: \ obj str n:1 i:1 → [[shift [rightpoint obj n i] + (@signmarginslide,@signmarginoffset)] [center [Graphics..TeX [String..sprintf `$\scriptsize %s$´ str]] (0,0)]]
59 bottompointsign: \ obj str n:1 i:1 → [[shift [bottompoint obj n i] + (@signmarginoffset,~@signmarginslide)] [center [Graphics..TeX [String..sprintf `$\scriptsize %s$´ str]] (0,0)]]
60 toppointsign: \ obj str n:1 i:1 → [[shift [toppoint obj n i] + (~@signmarginoffset,@signmarginslide)] [center [Graphics..TeX [String..sprintf `$\scriptsize %s$´ str]] (0,0)]]
62 putblockOrigin: \ •dst newBlock → {
67 putblockLeft: \ •dst newBlock oldBlock dist → {
68 res: [[shift [leftpoint oldBlock 1 1]+(~dist,0)] [Layout..center_x newBlock 1]]
72 putblockNearLeft: \ •dst newBlock oldBlock → [putblockLeft •dst newBlock oldBlock @blockspacenear]
73 putblockFarLeft: \ •dst newBlock oldBlock → [putblockLeft •dst newBlock oldBlock @blockspacefar]
74 putblockVeryNearLeft: \ •dst newBlock oldBlock → [putblockLeft •dst newBlock oldBlock @blockspaceverynear]
75 putblockVeryFarLeft: \ •dst newBlock oldBlock → [putblockLeft •dst newBlock oldBlock @blockspaceveryfar]
76 putblockLabelSpaceLeft: \ •dst newBlock oldBlock → [putblockLeft •dst newBlock oldBlock @blockspacelabelspace]
77 putblockLabelMarginLeft: \ •dst newBlock oldBlock → [putblockLeft •dst newBlock oldBlock @leftrightlabelmargin]
79 putblockRight: \ •dst newBlock oldBlock dist → {
80 res: [[shift [rightpoint oldBlock 1 1]+(dist,0)] [Layout..center_x newBlock ~1]]
84 putblockNearRight: \ •dst newBlock oldBlock → [putblockRight •dst newBlock oldBlock @blockspacenear]
85 putblockFarRight: \ •dst newBlock oldBlock → [putblockRight •dst newBlock oldBlock @blockspacefar]
86 putblockVeryNearRight: \ •dst newBlock oldBlock → [putblockRight •dst newBlock oldBlock @blockspaceverynear]
87 putblockVeryFarRight: \ •dst newBlock oldBlock → [putblockRight •dst newBlock oldBlock @blockspaceveryfar]
88 putblockLabelSpaceRight: \ •dst newBlock oldBlock → [putblockRight •dst newBlock oldBlock @blockspacelabelspace]
89 putblockLabelMarginRight: \ •dst newBlock oldBlock → [putblockRight •dst newBlock oldBlock @leftrightlabelmargin]
91 putblockBelow: \ •dst newBlock oldBlock dist → {
92 res: [[shift [bottompoint oldBlock 1 1]+(0,~dist)] [Layout..center_y newBlock 1]]
96 putblockNearBelow: \ •dst newBlock oldBlock → [putblockBelow •dst newBlock oldBlock @blockspacenear]
97 putblockFarBelow: \ •dst newBlock oldBlock → [putblockBelow •dst newBlock oldBlock @blockspacefar]
98 putblockVeryNearBelow: \ •dst newBlock oldBlock → [putblockBelow •dst newBlock oldBlock @blockspaceverynear]
99 putblockVeryFarBelow: \ •dst newBlock oldBlock → [putblockBelow •dst newBlock oldBlock @blockspaceveryfar]
100 putblockLabelSpaceBelow: \ •dst newBlock oldBlock → [putblockBelow •dst newBlock oldBlock @blockspacelabelspace]
101 putblockLabelMarginBelow: \ •dst newBlock oldBlock → [putblockBelow •dst newBlock oldBlock @belowlabelmargin]
103 putblockAbove: \ •dst newBlock oldBlock dist → {
104 res: [[shift [toppoint oldBlock 1 1]+(0,dist)] [Layout..center_y newBlock ~1]]
108 putblockNearAbove: \ •dst newBlock oldBlock → [putblockAbove •dst newBlock oldBlock @blockspacenear]
109 putblockFarAbove: \ •dst newBlock oldBlock → [putblockAbove •dst newBlock oldBlock @blockspacefar]
110 putblockVeryNearAbove: \ •dst newBlock oldBlock → [putblockAbove •dst newBlock oldBlock @blockspaceverynear]
111 putblockVeryFarAbove: \ •dst newBlock oldBlock → [putblockAbove •dst newBlock oldBlock @blockspaceveryfar]
112 putblockLabelSpaceAbove: \ •dst newBlock oldBlock → [putblockAbove •dst newBlock oldBlock @blockspacelabelspace]
113 putblockLabelMarginAbove: \ •dst newBlock oldBlock → [putblockAbove •dst newBlock oldBlock @abovelabelmargin]
115 sizedblock: \ lbl rx ry →
117 ( @width:@blocklw | [@blockpainter (~rx,~ry)--(~rx,ry)--(rx,ry)--(rx,~ry)--cycle] )
119 [centerlabel [@textscaling lbl]]
122 longblock: \ lbl → [sizedblock lbl @longblockrx @longblockry]
123 squareblock: \ lbl → [sizedblock lbl @smallblockr @smallblockr]
124 fracblock: \ lbl → [sizedblock lbl @longblockrx @fracblockry]
126 longenoughblock: \ lbl → [sizedblock lbl [Numeric..Math..max @longblockrx 1mm+0.5*([xmax [Layout..bbox lbl]]-[xmin [Layout..bbox lbl]])] @longblockry]
127 longenoughfracblock: \ lbl → [sizedblock lbl [Numeric..Math..max @longblockrx 1mm+0.5*([xmax [Layout..bbox lbl]]-[xmin [Layout..bbox lbl]])] @fracblockry]
131 ( @width:@blocklw | [@blockpainter [Geometry..circle @smallblockr]] )
133 [center [@textscaling lbl] (0,0)]
136 sumpicture: \ → [roundblock [Graphics..TeX `$\Sigma$´]]
138 splitdot: \ → ( @nonstroking:@stroking | [Graphics..fill [Geometry..circle 2.5 * @connectionlw]] )
140 termcircle: \ → ( @width:@connectionlw | [Graphics..stroke [Geometry..circle 3 * @connectionlw]] )
142 hhconnect: \ •dst pa pb mediation slide →
144 mid: [mediate mediation pa.x pb.x] + [if pb.x > pa.x 1 ~1] * slide
145 respath: pa--( mid, pa.y )--( mid, pb.y )--pb
146 •dst << @width:@connectionlw | [@connectpainter respath]
149 vvconnect: \ •dst pa pb mediation slide →
151 mid: [mediate mediation pa.y pb.y] + [if pb.y > pa.y 1 ~1 ] * slide
152 respath: pa--( pa.x, mid )--( pb.x, mid )--pb
153 •dst << @width:@connectionlw | [@connectpainter respath]
156 hvconnect: \ •dst pa pb →
158 respath: pa--( pb.x, pa.y )--pb
159 •dst << @width:@connectionlw | [@connectpainter respath]
162 vhconnect: \ •dst pa pb →
164 respath: pa--( pa.x, pb.y )--pb
165 •dst << @width:@connectionlw | [@connectpainter respath]
169 conlabel: \ shiftdir lbl z → [[shift z] [shiftoff_wlm lbl shiftdir]]
171 leftpoint: \ pic n:1 i:1 → { bb: [Layout..bbox pic] ([xmin bb], [mediate i/(n+1) [ymin bb] [ymax bb]])}
172 rightpoint: \ pic n:1 i:1 → { bb: [Layout..bbox pic] ([xmax bb], [mediate i/(n+1) [ymin bb] [ymax bb]])}
173 bottompoint: \ pic n:1 i:1 → { bb: [Layout..bbox pic] ([mediate i/(n+1) [xmin bb] [xmax bb]], [ymin bb])}
174 toppoint: \ pic n:1 i:1 → { bb: [Layout..bbox pic] ([mediate i/(n+1) [xmin bb] [xmax bb]], [ymax bb])}
176 llconnect: \ •dst pica picb slide → { z1:[leftpoint pica 1 1] z2:[leftpoint picb 1 1] [hhconnect •dst z1 z2 [if z1.x<z2.x 0 1] slide] }
177 rrconnect: \ •dst pica picb slide → { z1:[rightpoint pica 1 1] z2:[rightpoint picb 1 1] [hhconnect •dst z1 z2 [if z1.x>z2.x 0 1] slide] }
178 bbconnect: \ •dst pica picb slide → { z1:[bottompoint pica 1 1] z2:[bottompoint picb 1 1] [vvconnect •dst z1 z2 [if z1.x<z2.x 0 1] slide] }
179 ttconnect: \ •dst pica picb slide → { z1:[toppoint pica 1 1] z2:[toppoint picb 1 1] [vvconnect •dst z1 z2 [if z1.x>z2.x 0 1] slide] }
181 lrconnect: \ •dst pica picb mediation:0.5 slide:0cm → [hhconnect •dst [leftpoint pica 1 1] [rightpoint picb 1 1] mediation slide]
182 rlconnect: \ •dst pica picb mediation:0.5 slide:0cm → [hhconnect •dst [rightpoint pica 1 1] [leftpoint picb 1 1] mediation slide]
183 btconnect: \ •dst pica picb mediation:0.5 slide:0cm → [vvconnect •dst [bottompoint pica 1 1] [toppoint picb 1 1] mediation slide]
184 tbconnect: \ •dst pica picb mediation:0.5 slide:0cm → [vvconnect •dst [toppoint pica 1 1] [bottompoint picb 1 1] mediation slide]
186 ltconnect: \ •dst pica picb → [hvconnect •dst [leftpoint pica 1 1] [toppoint picb 1 1]]
187 lbconnect: \ •dst pica picb → [hvconnect •dst [leftpoint pica 1 1] [bottompoint picb 1 1]]
188 rtconnect: \ •dst pica picb → [hvconnect •dst [rightpoint pica 1 1] [toppoint picb 1 1]]
189 rbconnect: \ •dst pica picb → [hvconnect •dst [rightpoint pica 1 1] [bottompoint picb 1 1]]
190 tlconnect: \ •dst pica picb → [vhconnect •dst [toppoint pica 1 1] [leftpoint picb 1 1]]
191 trconnect: \ •dst pica picb → [vhconnect •dst [toppoint pica 1 1] [rightpoint picb 1 1]]
192 blconnect: \ •dst pica picb → [vhconnect •dst [bottompoint pica 1 1] [leftpoint picb 1 ]]
193 brconnect: \ •dst pica picb → [vhconnect •dst [bottompoint pica 1 1] [rightpoint picb 1 1]]
195 connect: \ •dst pica picb →
197 bba: [Layout..bbox pica]
198 bbb: [Layout..bbox picb]
199 rxa: 0.5 * ( [xmax bba] - [xmin bba] )
200 rxb: 0.5 * ( [xmax bbb] - [xmin bbb] )
201 rya: 0.5 * ( [ymax bba] - [ymin bba] )
202 ryb: 0.5 * ( [ymax bbb] - [ymin bbb] )
203 ca: [Geometry..pathpoint_mean bba]
204 cb: [Geometry..pathpoint_mean bbb]
205 [if ca.x < cb.x - ( rxa + rxb )
206 [if ca.y < cb.y - ( rya + ryb )
207 [rbconnect •dst pica picb]
208 [if ca.y > cb.y + ( rya + ryb )
209 [rtconnect •dst pica picb]
210 [rlconnect •dst pica picb]
212 [if ca.x > cb.x + ( rxa + rxb )
213 [if ca.y < cb.y - ( rya + ryb )
214 [lbconnect •dst pica picb]
215 [if ca.y > cb.y + ( rya + ryb )
216 [ltconnect •dst pica picb]
217 [lrconnect •dst pica picb]
219 [if ca.y < cb.y - ( rya + ryb )
220 [tbconnect •dst pica picb]
221 [if ca.y > cb.y + ( rya + ryb )
222 [btconnect •dst pica picb]
223 [hvconnect •dst ca cb]