resources/extensions/Applications/Blockdraw/bondgraph.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 / blockdraw
  20 ##needs ..Shapes..Layout / basic-layout
  21 ##needs ..Shapes..Layout / shiftoff
  22 ##needs ..Shapes..Graphics / arrowheads
  23
  24 ##lookin ..Shapes
  25 ##lookin ..Shapes..Layout
  26
  27 junction: \ txt → [Layout..bboxed [center txt (0,0)] [Geometry..rectangle (~@smallblockr,~@smallblockr) (@smallblockr,@smallblockr)]]
  28
  29 pjunction: [junction [Graphics..TeX `p´]]
  30 sjunction: [junction [Graphics..TeX `s´]]
  31
  32 junctionlbl: \ txt arrowdir lbl doArrow →
  33 {
  34   ahLength: 1.5mm
  35   ahAngle: 30°
  36   tmppic: [junction txt]
  37   thebb: [Layout..bbox tmppic]
  38   pOffset: 0bp           |**  @connectionlw + ahLength*[Numeric..Math..sin 0.5*ahAngle]
  39   p: [if arrowdir = to_lft [[shift (0,pOffset)] ([xmax thebb],[ymax thebb])--([xmin thebb],[ymax thebb])]
  40       [if arrowdir = to_rt [[shift (0,pOffset)] ([xmin thebb],[ymax thebb])--([xmax thebb],[ymax thebb])]
  41        [if arrowdir = to_bot [[shift (pOffset,0)] ([xmax thebb],[ymax thebb])--([xmax thebb],[ymin thebb])]
  42         [if arrowdir = to_top [[shift (pOffset,0)] ([xmax thebb],[ymin thebb])--([xmax thebb],[ymax thebb])]
  43    [error [String..sprintf `Bad arrowdir constant: %g´ arrowdir]]]]]]
  44   d: [if arrowdir = to_lft to_top
  45       [if arrowdir = to_rt to_top
  46        [if arrowdir = to_bot to_rt
  47         [if arrowdir = to_top to_rt
  48    [error [String..sprintf `Bad arrowdir constant: %g´ arrowdir]]]]]]
  49
  50   [bboxed_sym
  51     (newGroup
  52        << [if doArrow
  53         [Graphics..stroke p head: [Graphics..triangleArrow ahLength:ahLength ahAngle:ahAngle ...]]
  54          null]
  55        << [conlabel d lbl [mspoint p 0.5]]
  56        << tmppic )]
  57 }
  58
  59 tfjunction: \ arrowdir lbl → [junctionlbl [Graphics..TeX `TF´] arrowdir lbl true]
  60 gyjunction: \ arrowdir lbl → [junctionlbl [Graphics..TeX `GY´] arrowdir lbl false]
  61
  62
  63
  64 putblockTerminal: \ newBlock pos oldBlock →
  65 {
  66   r: [normalized pos - [centerof oldBlock]]
  67   res: [[shift pos] [bboxed_sym [shiftoff_wlm newBlock [to_dir r]]>>[shift  ~r * @smallblockr]]]
  68   res
  69 }
  70
  71 bgconnect: \ pica picb →
  72 {
  73   ca: [centerof pica]
  74   cb: [centerof picb]
  75   d: [if [Numeric..Math..abs ca - cb] = 0bp
  76          (1,0)
  77    [normalized cb - ca]]
  78   (ca + d * @smallblockr)--(cb - d * @smallblockr)
  79 }
  80
  81 dynamic @bgArrowWidth identity 4bp
  82
  83 bondgraphArrow: \ p doHook:false doCausal:false ahAngle:20° fillAsStroking:true →
  84  (@blend:Traits..Blend..NORMAL
  85   |
  86   { theLength: @bgArrowWidth / [Numeric..Math..sin ahAngle]
  87     hook:
  88     {
  89       sl: [p theLength]
  90       z: sl.p - sl.N * theLength * [Numeric..Math..sin ahAngle]
  91       @nonstroking:[if fillAsStroking @stroking @nonstroking]
  92       |
  93       [Graphics..fill [[shift sl.N * 0.5 * @width] [p 0]--sl]--z--cycle]
  94     }
  95     causal:
  96     {
  97       sl: [p 0]
  98       z: sl.p + sl.rT * @width
  99       r: sl.N * theLength * [Numeric..Math..sin ahAngle]
 100       @width: 1.5*@width
 101       |
 102       [Graphics..stroke (z-r)--(z+r)]
 103     }
 104     (>
 105       picture:
 106         ( newGroup
 107           << [if doHook
 108                  hook
 109                  null]
 110           << [if doCausal
 111                  causal
 112                  null] )
 113       cut:
 114         [if doHook
 115             0.8 * theLength
 116             @width]
 117    <)
 118   }
 119  )
 120
 121 ubond: \ p → ( @width:@connectionlw | [Graphics..stroke p head:[bondgraphArrow doHook:true ...]] )
 122 hbond: \ p → ( @width:@connectionlw | [Graphics..stroke p head:[bondgraphArrow doHook:true doCausal:true ...]] )
 123 tbond: \ p → ( @width:@connectionlw | [Graphics..stroke p head:[bondgraphArrow doHook:true ...] tail:[bondgraphArrow doCausal:true ...]] )
 124
 125 |**  the midpoint has typically singular direction, so we can't do the obvious:
 126 |**  draw( conlabel( to_dir( dir( angle( direction (0.5*length(p)) of p ) - 90 ) ), txt, mspoint( p, 0.5, 0 ) ) )
 127 |**  Actually, the above comment is a relic from the MetaPost implementation, and I no longer understand it as I
 128 |**  think that bond graph connections are _typically_ just straight lines.
 129 flowlabel: \ p lbl →
 130   [conlabel [to_dir [dir [angle [p ∞].p - [p 0].p] - 90°]] lbl [mspoint p 0.5]]
 131
 132 effortlabel: \ p lbl →
 133   [conlabel [to_dir [dir [angle [p ∞].p - [p 0].p] + 90°]] lbl [mspoint p 0.5]]
 134
 135
 136 /** The following two functions are conventience functions that factors out the oldBlock which appears at two places.
 137  ** They return the path so that it can be labeled.
 138  **/
 139 terminalfrom: \ •dst oldBlock pos newBlock →
 140 {
 141   t: [putblockTerminal newBlock pos oldBlock]
 142    •dst << t
 143   [bgconnect oldBlock t]
 144 }
 145 terminalto: \ •dst oldBlock pos newBlock →
 146 {
 147   t: [putblockTerminal newBlock pos oldBlock]
 148    •dst << t
 149   [bgconnect t oldBlock]
 150 }