ps/music-drawing-routines.ps

   1 %!PS-Adobe-1.0: music-drawing-routines.ps
   2 %
   3 % Functions for direct and embedded PostScript
   4
   5 /blot-diameter { lilypondpaperblotdiameter } bind def
   6
   7 % fucking redhat xdvi patch.
   8 /skeel { scale } bind def
   9
  10
  11 /set_tex_dimen {
  12         cvr def
  13 } bind def
  14
  15 /euclidean_length
  16 {
  17         1 copy mul exch 1 copy mul add sqrt
  18 } bind def
  19
  20 /skeel { scale } bind def
  21 % FIXME.  translate to middle of box.
  22 % Nice rectangle with rounded corners
  23 /draw_box % breapth width depth height
  24 {
  25         currentdict /testing known {
  26                 %% real thin lines for testing
  27                 /blot 0.005 def
  28         }{
  29                 /blot blot-diameter def
  30         } ifelse
  31
  32         0 setlinecap
  33         blot setlinewidth
  34         1 setlinejoin
  35
  36         blot 2 div sub /h exch def
  37         blot 2 div sub /d exch def
  38         blot 2 div sub /w exch def
  39         blot 2 div sub /b exch def
  40
  41         b neg d neg moveto
  42         b w add 0 rlineto
  43         0 d h add rlineto
  44         b w add neg 0 rlineto
  45         0 d h add neg rlineto
  46
  47         currentdict /testing known {
  48                 %% outline only, for testing:
  49                 stroke
  50         }{
  51                 closepath gsave stroke grestore fill
  52         } ifelse
  53 } bind def
  54
  55 /draw_round_box % breapth width depth height blot
  56 {
  57         /blot exch def
  58
  59         0 setlinecap
  60         blot setlinewidth
  61         1 setlinejoin
  62
  63         blot 2 div sub /h exch def
  64         blot 2 div sub /d exch def
  65         blot 2 div sub /w exch def
  66         blot 2 div sub /b exch def
  67
  68         b neg d neg moveto
  69         b w add 0 rlineto
  70         0 d h add rlineto
  71         b w add neg 0 rlineto
  72         0 d h add neg rlineto
  73
  74         currentdict /testing known {
  75                 %% outline only, for testing:
  76                 stroke
  77         }{
  78                 closepath gsave stroke grestore fill
  79         } ifelse
  80 } bind def
  81
  82 % Nice beam with rounded corners
  83 /draw_beam % slope width thick
  84 {
  85         currentdict /testing known {
  86                 %% real thin lines for testing
  87                 /blot 0.005 def
  88         }{
  89                 /blot blot-diameter def
  90         } ifelse
  91         blot setlinewidth
  92
  93         0 setlinecap
  94         1 setlinejoin
  95
  96         blot sub /t exch def
  97         blot sub /w exch def
  98         w mul /h exch def
  99
 100         blot 2 div t 2 div neg moveto
 101         w h rlineto
 102         0 t rlineto
 103         w neg h neg rlineto
 104         0 t neg rlineto
 105
 106         currentdict /testing known {
 107                 %% outline only, for testing:
 108                 stroke
 109         }{
 110                 closepath gsave stroke grestore fill
 111         } ifelse
 112 } bind def
 113
 114 /draw_repeat_slash % width slope thick
 115 {
 116         1 setlinecap
 117         1 setlinejoin
 118
 119         /beamthick exch def
 120         /slope exch def
 121         /width exch def
 122         beamthick beamthick slope div euclidean_length
 123           /xwid exch def
 124         0 0 moveto
 125         xwid 0  rlineto
 126         width slope width mul rlineto
 127         xwid neg 0 rlineto
 128       %  width neg width angle sin mul neg rlineto
 129         closepath fill
 130 } bind def
 131
 132 /draw_hairpin % width start_h end_h thick
 133 {
 134         1 setlinecap
 135         1 setlinejoin
 136
 137         setlinewidth
 138         /end_h exch def
 139         /start_h exch def
 140         /wid exch def
 141         0 start_h moveto
 142         wid end_h lineto
 143         stroke
 144         0 start_h neg moveto
 145         wid end_h neg lineto
 146         stroke
 147 } bind def
 148
 149 /draw_tuplet % height gap dx dy thick dir
 150 {
 151         1 setlinecap
 152         1 setlinejoin
 153
 154         /dir exch def
 155         setlinewidth
 156         /tuplet_dy exch def
 157         /tuplet_dx exch def
 158         /tuplet_gapx exch def
 159         /tuplet_h exch def
 160         tuplet_dy tuplet_dx div tuplet_gapx mul /tuplet_gapy exch def
 161
 162
 163         0 tuplet_h neg dir mul moveto
 164         0 0 lineto
 165         tuplet_dx tuplet_gapx sub 2 div
 166                 tuplet_dy tuplet_gapy sub 2 div  lineto
 167         tuplet_dx tuplet_gapx add 2 div
 168                 tuplet_dy tuplet_gapy add 2 div  moveto
 169         tuplet_dx tuplet_dy lineto
 170         tuplet_dx tuplet_dy tuplet_h dir neg mul add lineto
 171         stroke
 172 } bind def
 173
 174 /draw_ez_ball % ch letter_col ball_col font
 175 {
 176         % font
 177         findfont 0.7 scalefont setfont
 178         0.1 setlinewidth
 179         0 0 moveto
 180         0 setgray
 181         0.5 0 0.5 0 360 arc closepath fill stroke
 182         % ball_col
 183         1 eq {
 184                 0.01 setlinewidth
 185                 1 setgray
 186                 0.5 0 0.4 0 360 arc closepath
 187                 fill stroke
 188         } if
 189         % letter_col
 190         setgray
 191         % 0.25 is empiric centering. Change to taste
 192         0.25 -0.25 moveto
 193         % ch
 194         show
 195 } bind def
 196
 197 % Simple, but does it work everywhere?
 198 % Han-Wen reports that one printer (brand?) at cs.uu.nl chokes on this,
 199 % reverted for now -- jcn
 200 %
 201 % The filled circles are drawn by setting the linewidth
 202 % to 2*radius and drawing a point.
 203 /simple_draw_ez_ball % ch letter_col ball_col font
 204 {
 205         % font
 206         findfont 0.85 scalefont setfont
 207         /origin { 0.45 0 } def
 208         0 setgray
 209         1.1 setlinewidth
 210         origin moveto
 211         origin lineto stroke
 212         % ball_col
 213         setgray
 214         0.9 setlinewidth
 215         origin moveto
 216         origin lineto stroke
 217         % letter_col
 218         setgray
 219         % 0.25 is empiric centering. Change to taste
 220         origin moveto
 221         -0.28 -0.30 rmoveto
 222         % ch
 223         show
 224 } bind def
 225
 226 /draw_volta % h w thick vert_start vert_end
 227 {
 228         1 setlinecap
 229         1 setlinejoin
 230
 231         /vert_end exch def
 232         /vert_start exch def
 233         setlinewidth
 234         /volta_w exch def
 235         /volta_h exch def
 236         vert_start 0 eq {
 237                 0 0 moveto
 238                 0 volta_h lineto
 239         } if
 240         0 volta_h moveto
 241         volta_w volta_h lineto
 242         vert_end 0 eq {
 243                 volta_w 0 lineto
 244         } if
 245         stroke
 246 } bind def
 247
 248 % this is for drawing slurs.
 249 /draw_bezier_sandwich  % thickness controls
 250 {
 251         setlinewidth
 252         moveto
 253         curveto
 254         lineto
 255         curveto
 256         gsave
 257         fill
 258         grestore
 259         stroke
 260 } bind def
 261
 262 /draw_dot % x1 y2 R
 263 {
 264 %       0 360 arc fill stroke
 265         0 360 arc closepath fill stroke
 266 } bind def
 267
 268 /draw_dashed_line % dash thickness dx dy
 269 {
 270         1 setlinecap
 271         1 setlinejoin
 272         setdash
 273         setlinewidth
 274         0 0 moveto
 275         lineto
 276         stroke
 277 } bind def
 278
 279 /draw_dashed_slur % dash thickness controls
 280 {
 281         1 setlinecap
 282         1 setlinejoin
 283         setdash
 284         setlinewidth
 285         8 -2 roll
 286         moveto
 287         curveto
 288         stroke
 289 } bind def
 290
 291
 292
 293 /bracket_traject
 294 {
 295         /traject_ds exch def
 296         /traject_alpha exch def
 297         traject_ds traject_alpha sin mul add
 298         exch
 299         traject_ds traject_alpha cos mul add
 300         exch
 301 } bind def
 302
 303
 304
 305 /half_bracket
 306 {
 307 %6
 308         0 0
 309 %5a
 310         bracket_thick arch_height add half_height arch_thick sub arch_width add
 311         arch_angle arch_height -0.15 mul bracket_traject
 312 %5b
 313         bracket_thick 0.5 mul half_height
 314         0 arch_height 0.5 mul bracket_traject
 315 %5c
 316         0 half_height
 317 %4a
 318         bracket_thick half_height arch_thick sub
 319         0 arch_height 0.4 mul bracket_traject
 320 %4b
 321         bracket_thick arch_height add half_height arch_thick sub arch_width add
 322         arch_angle arch_height -0.25 mul bracket_traject
 323 %4c
 324         bracket_thick arch_height add half_height arch_thick sub arch_width add
 325 %3
 326         bracket_thick half_height arch_thick sub
 327 %2
 328         bracket_thick 0
 329 %1
 330         0 0
 331 } bind def
 332
 333 /draw_half_bracket {
 334         moveto
 335         lineto
 336         lineto
 337         curveto
 338         curveto
 339         lineto
 340         gsave
 341         fill
 342         grestore
 343 } bind def
 344
 345 /draw_bracket % arch_angle arch_width arch_height bracket_height arch_thick bracket_thick
 346 {
 347         % urg
 348
 349         /bracket_thick exch def
 350         /arch_thick exch def
 351         /bracket_height exch def
 352         /arch_height exch def
 353         /arch_width exch def
 354         /arch_angle exch def
 355
 356         bracket_height 2 div bracket_thick add /half_height exch def
 357         bracket_thick 0.5 mul setlinewidth
 358         1 setlinecap
 359         1 setlinejoin
 360         half_bracket
 361         20 copy
 362         1 -1 scale
 363         draw_half_bracket
 364         stroke
 365         1 -1 scale
 366         draw_half_bracket
 367         stroke
 368 } bind def
 369