resources/extensions/blockdraw_wfo.shext

   1 /** This file is part of Shapes.
   2  **
   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
   6  ** any later version.
   7  **
   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.
  12  **
  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/>.
  15  **
  16  ** Copyright 2008 Henrik Tidefelt
  17  **/
  18
  19 |** This is "blockdraw, Waiting For Object oriented programming
  20
  21 ##needs shiftoff
  22 ##needs centering
  23 ##needs circle
  24 ##needs arrowheads
  25
  26 dynamic @longblockrx identity 0.7cm
  27 dynamic @longblockry identity 0.4cm
  28 dynamic @smallblockr identity 0.3cm
  29 dynamic @fracblockry identity 0.5cm
  30
  31 dynamic @connectionlw identity 0.8bp
  32 dynamic @blocklw identity 0.8bp
  33
  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
  39
  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
  45
  46 dynamic @textscaling identity [scale 1]
  47
  48 dynamic @connectpainter identity [stroke head:MetaPostArrow ...]
  49
  50 centerlabel: \ obj .> [centerx [centeryX obj]]
  51
  52 putlabelAbove: \ lbl z x .> [[shift z + (0cm,@abovelabelmargin)] [centerxat lbl x]]
  53 putlabelBelow: \ lbl z x .> [[shift z + (0cm,~@belowlabelmargin)] [centeryatX [centerxat lbl x] 1]]
  54 putlabelLeft: \ lbl z y .> [[shift z + (~@leftrightlabelmargin,0cm)] [centeryatX [centerxat lbl 1] y]]
  55 putlabelRight: \ lbl z y .> [[shift z + (@leftrightlabelmargin,0cm)] [centeryatX lbl y]]
  56 leftpointsign: \ obj str n:1 i:1 .> [[shift [leftpoint obj n i] + (~@signmarginslide,~@signmarginoffset)] [centerat (TeX [sprintf `$\scriptsize %s$´ str]) (0,0)]]
  57 rightpointsign: \ obj str n:1 i:1 .> [[shift [rightpoint obj n i] + (@signmarginslide,@signmarginoffset)] [centerat (TeX [sprintf `$\scriptsize %s$´ str]) (0,0)]]
  58 bottompointsign: \ obj str n:1 i:1 .> [[shift [bottompoint obj n i] + (@signmarginoffset,~@signmarginslide)] [centerat (TeX [sprintf `$\scriptsize %s$´ str]) (0,0)]]
  59 toppointsign: \ obj str n:1 i:1 .> [[shift [toppoint obj n i] + (~@signmarginoffset,@signmarginslide)] [centerat (TeX [sprintf `$\scriptsize %s$´ str]) (0,0)]]
  60
  61 putblockOrigin: \ •dst newBlock .> {
  62   •dst << newBlock
  63   newBlock
  64 }
  65
  66 putblockLeft: \ •dst newBlock oldBlock dist .> {
  67   res: [[shift [leftpoint oldBlock 1 1]+(~dist,0)] [centerxat newBlock 1]]
  68   •dst << res
  69   res
  70 }
  71 putblockNearLeft: \ •dst newBlock oldBlock .> [putblockLeft •dst newBlock oldBlock @blockspacenear]
  72 putblockFarLeft: \ •dst newBlock oldBlock .> [putblockLeft •dst newBlock oldBlock @blockspacefar]
  73 putblockVeryNearLeft: \ •dst newBlock oldBlock .> [putblockLeft •dst newBlock oldBlock @blockspaceverynear]
  74 putblockVeryFarLeft: \ •dst newBlock oldBlock .> [putblockLeft •dst newBlock oldBlock @blockspaceveryfar]
  75 putblockLabelSpaceLeft: \ •dst newBlock oldBlock .> [putblockLeft •dst newBlock oldBlock @blockspacelabelspace]
  76 putblockLabelMarginLeft: \ •dst newBlock oldBlock .> [putblockLeft •dst newBlock oldBlock @leftrightlabelmargin]
  77
  78 putblockRight: \ •dst newBlock oldBlock dist .> {
  79   res: [[shift [rightpoint oldBlock 1 1]+(dist,0)] [centerxat newBlock ~1]]
  80   •dst << res
  81   res
  82 }
  83 putblockNearRight: \ •dst newBlock oldBlock .> [putblockRight •dst newBlock oldBlock @blockspacenear]
  84 putblockFarRight: \ •dst newBlock oldBlock .> [putblockRight •dst newBlock oldBlock @blockspacefar]
  85 putblockVeryNearRight: \ •dst newBlock oldBlock .> [putblockRight •dst newBlock oldBlock @blockspaceverynear]
  86 putblockVeryFarRight: \ •dst newBlock oldBlock .> [putblockRight •dst newBlock oldBlock @blockspaceveryfar]
  87 putblockLabelSpaceRight: \ •dst newBlock oldBlock .> [putblockRight •dst newBlock oldBlock @blockspacelabelspace]
  88 putblockLabelMarginRight: \ •dst newBlock oldBlock .> [putblockRight •dst newBlock oldBlock @leftrightlabelmargin]
  89
  90 putblockBelow: \ •dst newBlock oldBlock dist .> {
  91   res: [[shift [bottompoint oldBlock 1 1]+(0,~dist)] [centeryat newBlock 1]]
  92   •dst << res
  93   res
  94 }
  95 putblockNearBelow: \ •dst newBlock oldBlock .> [putblockBelow •dst newBlock oldBlock @blockspacenear]
  96 putblockFarBelow: \ •dst newBlock oldBlock .> [putblockBelow •dst newBlock oldBlock @blockspacefar]
  97 putblockVeryNearBelow: \ •dst newBlock oldBlock .> [putblockBelow •dst newBlock oldBlock @blockspaceverynear]
  98 putblockVeryFarBelow: \ •dst newBlock oldBlock .> [putblockBelow •dst newBlock oldBlock @blockspaceveryfar]
  99 putblockLabelSpaceBelow: \ •dst newBlock oldBlock .> [putblockBelow •dst newBlock oldBlock @blockspacelabelspace]
 100 putblockLabelMarginBelow: \ •dst newBlock oldBlock .> [putblockBelow •dst newBlock oldBlock @belowlabelmargin]
 101
 102 putblockAbove: \ •dst newBlock oldBlock dist .> {
 103   res: [[shift [toppoint oldBlock 1 1]+(0,dist)] [centeryat newBlock ~1]]
 104   •dst << res
 105   res
 106 }
 107 putblockNearAbove: \ •dst newBlock oldBlock .> [putblockAbove •dst newBlock oldBlock @blockspacenear]
 108 putblockFarAbove: \ •dst newBlock oldBlock .> [putblockAbove •dst newBlock oldBlock @blockspacefar]
 109 putblockVeryNearAbove: \ •dst newBlock oldBlock .> [putblockAbove •dst newBlock oldBlock @blockspaceverynear]
 110 putblockVeryFarAbove: \ •dst newBlock oldBlock .> [putblockAbove •dst newBlock oldBlock @blockspaceveryfar]
 111 putblockLabelSpaceAbove: \ •dst newBlock oldBlock .> [putblockAbove •dst newBlock oldBlock @blockspacelabelspace]
 112 putblockLabelMarginAbove: \ •dst newBlock oldBlock .> [putblockAbove •dst newBlock oldBlock @abovelabelmargin]
 113
 114 sizedblock: \ lbl rx ry .>
 115  (
 116    [centerlabel [@textscaling lbl]]
 117    &
 118    ( @width:@blocklw | [stroke (~rx,~ry)--(~rx,ry)--(rx,ry)--(rx,~ry)--cycle] )
 119  )
 120
 121 longblock: \ lbl .> [sizedblock lbl @longblockrx @longblockry]
 122 squareblock: \ lbl .> [sizedblock lbl @smallblockr @smallblockr]
 123 fracblock: \ lbl .> [sizedblock lbl @longblockrx @fracblockry]
 124
 125 longenoughblock: \ lbl .> [sizedblock lbl [max @longblockrx 1mm+0.5*([xmax [bbox lbl]]-[xmin [bbox lbl]])] @longblockry]
 126 longenoughfracblock: \ lbl .> [sizedblock lbl [max @longblockrx 1mm+0.5*([xmax [bbox lbl]]-[xmin [bbox lbl]])] @fracblockry]
 127
 128 roundblock: \ lbl .>
 129   (
 130     [centerat [@textscaling lbl] (0,0)]
 131     &
 132     ( @width:@blocklw | [stroke [circle @smallblockr]] )
 133   )
 134
 135 sumpicture: \ .> [roundblock (TeX `$\Sigma$´)]
 136
 137 splitdot: \ .> ( @nonstroking:@stroking | [fill [circle 2.5 * @connectionlw]] )
 138
 139 termcircle: \ .> ( @width:@connectionlw | [stroke [circle 3 * @connectionlw]] )
 140
 141 hhconnect: \ •dst pa pb mediation slide .>
 142  {
 143    mid: [mediate mediation pa.x pb.x] + [if pb.x > pa.x 1 ~1] * slide
 144    respath: pa--( mid, pa.y )--( mid, pb.y )--pb
 145    •dst << @width:@connectionlw | [@connectpainter respath]
 146    respath
 147   }
 148 vvconnect: \ •dst pa pb mediation slide .>
 149   {
 150     mid: [mediate mediation pa.y pb.y] + [if pb.y > pa.y 1 ~1 ] * slide
 151     respath: pa--( pa.x, mid )--( pb.x, mid )--pb
 152     •dst << @width:@connectionlw | [@connectpainter respath]
 153     respath
 154   }
 155 hvconnect: \ •dst pa pb .>
 156   {
 157     respath: pa--( pb.x, pa.y )--pb
 158     •dst << @width:@connectionlw | [@connectpainter respath]
 159     respath
 160   }
 161 vhconnect: \ •dst pa pb .>
 162   {
 163     respath: pa--( pa.x, pb.y )--pb
 164     •dst << @width:@connectionlw | [@connectpainter respath]
 165     respath
 166   }
 167
 168 conlabel: \ shiftdir lbl z .> [[shift z] [shiftoffwlm lbl shiftdir]]
 169
 170 leftpoint:   \ pic n:1 i:1 .> { bb: [bbox pic] ([xmin bb], [mediate i/(n+1) [ymin bb] [ymax bb]])}
 171 rightpoint:  \ pic n:1 i:1 .> { bb: [bbox pic] ([xmax bb], [mediate i/(n+1) [ymin bb] [ymax bb]])}
 172 bottompoint: \ pic n:1 i:1 .> { bb: [bbox pic] ([mediate i/(n+1) [xmin bb] [xmax bb]], [ymin bb])}
 173 toppoint:    \ pic n:1 i:1 .> { bb: [bbox pic] ([mediate i/(n+1) [xmin bb] [xmax bb]], [ymax bb])}
 174
 175 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] }
 176 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] }
 177 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] }
 178 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] }
 179
 180 lrconnect: \ •dst pica picb mediation:0.5 slide:0cm .> [hhconnect •dst [leftpoint pica 1 1] [rightpoint picb 1 1] mediation slide]
 181 rlconnect: \ •dst pica picb mediation:0.5 slide:0cm .> [hhconnect •dst [rightpoint pica 1 1] [leftpoint picb 1 1] mediation slide]
 182 btconnect: \ •dst pica picb mediation:0.5 slide:0cm .> [vvconnect •dst [bottompoint pica 1 1] [toppoint picb 1 1] mediation slide]
 183 tbconnect: \ •dst pica picb mediation:0.5 slide:0cm .> [vvconnect •dst [toppoint pica 1 1] [bottompoint picb 1 1] mediation slide]
 184
 185 ltconnect: \ •dst pica picb .> [hvconnect •dst [leftpoint pica 1 1] [toppoint picb 1 1]]
 186 lbconnect: \ •dst pica picb .> [hvconnect •dst [leftpoint pica 1 1] [bottompoint picb 1 1]]
 187 rtconnect: \ •dst pica picb .> [hvconnect •dst [rightpoint pica 1 1] [toppoint picb 1 1]]
 188 rbconnect: \ •dst pica picb .> [hvconnect •dst [rightpoint pica 1 1] [bottompoint picb 1 1]]
 189 tlconnect: \ •dst pica picb .> [vhconnect •dst [toppoint pica 1 1] [leftpoint picb 1 1]]
 190 trconnect: \ •dst pica picb .> [vhconnect •dst [toppoint pica 1 1] [rightpoint picb 1 1]]
 191 blconnect: \ •dst pica picb .> [vhconnect •dst [bottompoint pica 1 1] [leftpoint picb 1 ]]
 192 brconnect: \ •dst pica picb .> [vhconnect •dst [bottompoint pica 1 1] [rightpoint picb 1 1]]
 193
 194 connect: \ •dst pica picb .>
 195 {
 196   bba: [bbox pica]
 197   bbb: [bbox picb]
 198   rxa: 0.5 * ( [xmax bba] - [xmin bba] )
 199   rxb: 0.5 * ( [xmax bbb] - [xmin bbb] )
 200   rya: 0.5 * ( [ymax bba] - [ymin bba] )
 201   ryb: 0.5 * ( [ymax bbb] - [ymin bbb] )
 202   ca: [pathpoint_mean bba]
 203   cb: [pathpoint_mean bbb]
 204   [if ca.x < cb.x - ( rxa + rxb )
 205       [if ca.y < cb.y - ( rya + ryb )
 206         [rbconnect •dst pica picb]
 207       [if ca.y > cb.y + ( rya + ryb )
 208         [rtconnect •dst pica picb]
 209         [rlconnect •dst pica picb]
 210       ]]
 211   [if ca.x > cb.x + ( rxa + rxb )
 212       [if ca.y < cb.y - ( rya + ryb )
 213         [lbconnect •dst pica picb]
 214       [if ca.y > cb.y + ( rya + ryb )
 215         [ltconnect •dst pica picb]
 216         [lrconnect •dst pica picb]
 217       ]]
 218       [if ca.y < cb.y - ( rya + ryb )
 219         [tbconnect •dst pica picb]
 220       [if ca.y > cb.y + ( rya + ryb )
 221         [btconnect •dst pica picb]
 222         [hvconnect •dst ca cb]
 223       ]]
 224     ]]
 225 }