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