pst-solides3d.pro

   1 %!
   2 % PostScript prologue for pst-solides3d.tex.
   3 % Version 4.21, 2011/07/13
   4 %
   5 %% COPYRIGHT 2009/10 by Jean-Paul Vignault
   6 %% opacity changes by Herbert Voss
   7 %%
   8 %% This program can be redistributed and/or modified under the terms
   9 %% of the LaTeX Project Public License Distributed from CTAN
  10 %% archives in directory macros/latex/base/lppl.txt.
  11 %
  12 /SolidesDict 100 dict def
  13 /SolidesbisDict 100 dict def
  14 SolidesDict begin
  15
  16 %% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  17 %% %% les variables globales gerees par PSTricks %%
  18 %% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  19 %% %% les lignes dessous sont a decommenter si l on veut utiliser le
  20 %% %% fichier solides.pro independamment du package PSTricks
  21 %% /Dobs 20 def
  22 %% /THETA 20 def
  23 %% /PHI 50 def
  24 %% /Decran 30 def
  25 %% /XpointVue {Dobs Cos1Cos2 mul} def
  26 %% /YpointVue {Dobs Sin1Cos2 mul} def
  27 %% /ZpointVue {Dobs Sin2 mul} def
  28 %% /xunit 28.14 def
  29 %% /solidhollow false def
  30 %% /solidbiface false def
  31 %% /xunit 28.45 def
  32 %% /tracelignedeniveau? true def
  33 %% /hauteurlignedeniveau 1 def
  34 %% /couleurlignedeniveau {rouge} def
  35 %% /linewidthlignedeniveau 4 def
  36 %% /solidgrid true def
  37 /aretescachees true def
  38 /defaultsolidmode 2 def
  39 %
  40 /Stroke { strokeopacity .setopacityalpha stroke } def
  41 /Fill { fillopacity .setopacityalpha fill } def
  42 %
  43 %% variables globales specifiques a PSTricks
  44 %% /activationgestioncouleurs true def
  45 /xmin -10 def
  46 /xmax 10 def
  47 /ymin -10 def
  48 /ymax 10 def
  49
  50 /fillstyle {} def
  51 /startest false def
  52 /cm {} def
  53 /cm_1 {} def
  54 /yunit {xunit} def
  55 /angle_repere 90 def
  56
  57 /hadjust 2.5 def
  58 /vadjust 2.5 def
  59 /pl@n-en-cours false def
  60
  61 /pointilles { [6.25 3.75] 1.25 setdash } def
  62 /stockcurrentcpath {} def
  63 /newarrowpath {} def
  64 /chaine 15 string def
  65
  66 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  67 %% choix d une fonte accentuee pour le .ps %%
  68 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  69 /ReEncode { exch findfont
  70 dup length dict begin { 1 index /FID eq {pop pop} {def} ifelse
  71 }forall /Encoding ISOLatin1Encoding def currentdict end definefont
  72 pop }bind def
  73 /Font /Times-Roman /ISOfont ReEncode /ISOfont def
  74 %Font findfont 10 scalefont setfont
  75
  76 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  77 %% extrait de color.pro pour pouvoir recuperer ses couleurs %%
  78 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  79 /GreenYellow{0.15 0 0.69 0 setcmykcolor}def
  80 /Yellow{0 0 1 0 setcmykcolor}def
  81 /Goldenrod{0 0.10 0.84 0 setcmykcolor}def
  82 /Dandelion{0 0.29 0.84 0 setcmykcolor}def
  83 /Apricotq{0 0.32 0.52 0 setcmykcolor}def
  84 /Peach{0 0.50 0.70 0 setcmykcolor}def
  85 /Melon{0 0.46 0.50 0 setcmykcolor}def
  86 /YellowOrange{0 0.42 1 0 setcmykcolor}def
  87 /Orange{0 0.61 0.87 0 setcmykcolor}def
  88 /BurntOrange{0 0.51 1 0 setcmykcolor}def
  89 /Bittersweet{0 0.75 1 0.24 setcmykcolor}def
  90 /RedOrange{0 0.77 0.87 0 setcmykcolor}def
  91 /Mahogany{0 0.85 0.87 0.35 setcmykcolor}def
  92 /Maroon{0 0.87 0.68 0.32 setcmykcolor}def
  93 /BrickRed{0 0.89 0.94 0.28 setcmykcolor}def
  94 /Red{0 1 1 0 setcmykcolor}def
  95 /OrangeRed{0 1 0.50 0 setcmykcolor}def
  96 /RubineRed{0 1 0.13 0 setcmykcolor}def
  97 /WildStrawberry{0 0.96 0.39 0 setcmykcolor}def
  98 /Salmon{0 0.53 0.38 0 setcmykcolor}def
  99 /CarnationPink{0 0.63 0 0 setcmykcolor}def
 100 /Magenta{0 1 0 0 setcmykcolor}def
 101 /VioletRed{0 0.81 0 0 setcmykcolor}def
 102 /Rhodamine{0 0.82 0 0 setcmykcolor}def
 103 /Mulberry{0.34 0.90 0 0.02 setcmykcolor}def
 104 /RedViolet{0.07 0.90 0 0.34 setcmykcolor}def
 105 /Fuchsia{0.47 0.91 0 0.08 setcmykcolor}def
 106 /Lavender{0 0.48 0 0 setcmykcolor}def
 107 /Thistle{0.12 0.59 0 0 setcmykcolor}def
 108 /Orchid{0.32 0.64 0 0 setcmykcolor}def
 109 /DarkOrchid{0.40 0.80 0.20 0 setcmykcolor}def
 110 /Purple{0.45 0.86 0 0 setcmykcolor}def
 111 /Plum{0.50 1 0 0 setcmykcolor}def
 112 /Violet{0.79 0.88 0 0 setcmykcolor}def
 113 /RoyalPurple{0.75 0.90 0 0 setcmykcolor}def
 114 /BlueViolet{0.86 0.91 0 0.04 setcmykcolor}def
 115 /Periwinkle{0.57 0.55 0 0 setcmykcolor}def
 116 /CadetBlue{0.62 0.57 0.23 0 setcmykcolor}def
 117 /CornflowerBlue{0.65 0.13 0 0 setcmykcolor}def
 118 /MidnightBlue{0.98 0.13 0 0.43 setcmykcolor}def
 119 /NavyBlue{0.94 0.54 0 0 setcmykcolor}def
 120 /RoyalBlue{1 0.50 0 0 setcmykcolor}def
 121 /Blue{1 1 0 0 setcmykcolor}def
 122 /Cerulean{0.94 0.11 0 0 setcmykcolor}def
 123 /Cyan{1 0 0 0 setcmykcolor}def
 124 /ProcessBlue{0.96 0 0 0 setcmykcolor}def
 125 /SkyBlue{0.62 0 0.12 0 setcmykcolor}def
 126 /Turquoise{0.85 0 0.20 0 setcmykcolor}def
 127 /TealBlue{0.86 0 0.34 0.02 setcmykcolor}def
 128 /Aquamarine{0.82 0 0.30 0 setcmykcolor}def
 129 /BlueGreen{0.85 0 0.33 0 setcmykcolor}def
 130 /Emerald{1 0 0.50 0 setcmykcolor}def
 131 /JungleGreen{0.99 0 0.52 0 setcmykcolor}def
 132 /SeaGreen{0.69 0 0.50 0 setcmykcolor}def
 133 /Green{1 0 1 0 setcmykcolor}def
 134 /ForestGreen{0.91 0 0.88 0.12 setcmykcolor}def
 135 /PineGreen{0.92 0 0.59 0.25 setcmykcolor}def
 136 /LimeGreen{0.50 0 1 0 setcmykcolor}def
 137 /YellowGreen{0.44 0 0.74 0 setcmykcolor}def
 138 /SpringGreen{0.26 0 0.76 0 setcmykcolor}def
 139 /OliveGreen{0.64 0 0.95 0.40 setcmykcolor}def
 140 /RawSienna{0 0.72 1 0.45 setcmykcolor}def
 141 /Sepia{0 0.83 1 0.70 setcmykcolor}def
 142 /Brown{0 0.81 1 0.60 setcmykcolor}def
 143 /Tan{0.14 0.42 0.56 0 setcmykcolor}def
 144 /Gray{0 0 0 0.50 setcmykcolor}def
 145 /Black{0 0 0 1 setcmykcolor}def
 146 /White{0 0 0 0 setcmykcolor}def
 147 %% fin de l extrait color.pro
 148
 149 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 150 %%%%             autres couleurs                        %%%%
 151 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 152
 153 /bleu {0 0 1 setrgbcolor} def
 154 /rouge {1 0 0 setrgbcolor} def
 155 /vert {0 .5 0 setrgbcolor} def
 156 /gris {.4 .4 .4 setrgbcolor} def
 157 /jaune {1 1 0 setrgbcolor} def
 158 /noir {0 0 0 setrgbcolor} def
 159 /blanc {1 1 1 setrgbcolor} def
 160 /orange {1 .65 0 setrgbcolor} def
 161 /rose {1 .01 .58  setrgbcolor} def
 162 /cyan {1 0 0 0 setcmykcolor} def
 163 /magenta {0 1 0 0 setcmykcolor} def
 164
 165 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 166 %%%%             definition du point de vue             %%%%
 167 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 168 %% pour la 3D conventionnelle
 169 %% Dony : graphisme scientifique : page 187
 170 %% Editeur : Masson
 171
 172 %% calcul des coefficients de la matrice
 173 %% de transformation
 174 /Sin1 {THETA sin} def
 175 /Sin2 {PHI sin} def
 176 /Cos1 {THETA cos} def
 177 /Cos2 {PHI cos} def
 178 /Cos1Sin2 {Cos1 Sin2 mul} def
 179 /Sin1Sin2 {Sin1 Sin2 mul} def
 180 /Cos1Cos2 {Cos1 Cos2 mul} def
 181 /Sin1Cos2 {Sin1 Cos2 mul} def
 182
 183 /3dto2d {
 184 6 dict begin
 185    /Zcote exch def
 186    /Yordonnee exch def
 187    /Xabscisse exch def
 188    /xObservateur
 189       Xabscisse Sin1 mul neg Yordonnee Cos1 mul add
 190    def
 191    /yObservateur
 192       Xabscisse Cos1Sin2 mul neg Yordonnee Sin1Sin2 mul sub Zcote Cos2
 193       mul add
 194    def
 195    /zObservateur
 196       Xabscisse neg Cos1Cos2 mul Yordonnee Sin1Cos2 mul sub Zcote Sin2
 197       mul sub Dobs add
 198    def
 199    %% maintenant on depose les resultats sur la pile
 200    Decran xObservateur mul zObservateur div cm
 201    Decran yObservateur mul zObservateur div cm
 202 end
 203 } def
 204
 205 /getpointVue {
 206    XpointVue
 207    YpointVue
 208    ZpointVue
 209 } def
 210
 211 /GetCamPos {
 212    getpointVue
 213 } def
 214
 215 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 216 %%%%         jps modifie pour PSTricks                  %%%%
 217 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 218
 219 /solid {continu} def
 220 /dashed {pointilles} def
 221 /dotted { [2] 0 setdash } def
 222
 223 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 224 %%%%             geometrie basique                      %%%%
 225 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 226
 227 %% syntaxe~: [x1 y1 ... xn yn] ligne
 228 /ligne {
 229 gsave
 230    newpath
 231       dup 0 getp smoveto
 232       ligne_
 233       starfill
 234    Stroke
 235 grestore
 236 } def
 237
 238 %% syntaxe~: [x1 y1 ... xn yn] ligne_
 239 /ligne_ {
 240    reversep
 241    aload length 2 idiv
 242    {
 243       slineto
 244    } repeat
 245 } def
 246
 247 %% syntaxe~: [x1 y1 ... xn yn] polygone
 248 /polygone* {
 249 1 dict begin
 250    /startest {true} def
 251    polygone
 252 end
 253 } def
 254
 255 /polygone_ {
 256    newpath
 257       aload length 2 idiv
 258       3 copy pop
 259       smoveto
 260       {
 261          slineto
 262       } repeat
 263    closepath
 264 } def
 265
 266 /polygone {
 267    gsave
 268       polygone_
 269       starfill
 270       currentlinewidth 0 eq {} { Stroke } ifelse
 271    grestore
 272 } def
 273
 274 %% syntaxe : x y point
 275 /point {
 276 gsave
 277    1 setlinecap
 278    newpath
 279       smoveto
 280       0 0 rlineto
 281       5 setlinewidth
 282    Stroke
 283 grestore
 284 } def
 285
 286 /point_ {
 287    1 setlinecap
 288    5 setlinewidth
 289       smoveto
 290       0 0 rlineto
 291 } def
 292
 293 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 294 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 295 %%%%                                                    %%%%
 296 %%%%          insertion librairie jps                   %%%%
 297 %%%%                                                    %%%%
 298 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 299 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 300
 301 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 302 %%%%              le repere jps                         %%%%
 303 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 304
 305 %%%%% ### AAAopacity ###
 306
 307 %% les parametres pour la gestion de la transparence
 308
 309 /setstrokeopacity { /strokeopacity exch def } def
 310 /setfillopacity { /fillopacity exch def } def
 311
 312 %% d apres un code de Jean-Michel Sarlat
 313 %% http://melusine.eu.org/syracuse/swf/pdf2swf/setdash/
 314 %% Mise en reserve de la procedure stroke originelle.
 315 /sysstroke {systemdict /stroke get exec} def
 316 /sysfill {systemdict /fill get exec} def
 317 /sysatan {systemdict /atan get exec} def
 318 /atan {2 copy 0 0 eqp {pop pop 0} {sysatan} ifelse} def
 319 % Mise en place de la nouvelle procedure
 320 /Stroke { /strokeopacity where { /strokeopacity get }{ 1 } ifelse
 321    .setopacityalpha sysstroke
 322 } def
 323 /Fill { /fillopacity where { /fillopacity get }{ 1 } ifelse
 324    .setopacityalpha sysfill
 325 } def
 326
 327 %%%%% ### AAAscale ###
 328 %%%%%%%%%%%%%%%% les deplacements a l echelle %%%%%%%%%%%%%%%%%%%
 329
 330  /v@ct_I {xunit 0} def
 331  /v@ct_J {angle_repere cos yunit mul angle_repere sin yunit mul} def
 332
 333 /xscale {} def
 334 /yscale {} def
 335
 336 /xscale-1 {} def
 337 /yscale-1 {} def
 338
 339 /gtransform {} def
 340 /gtransform-1 {} def
 341
 342 /jtoppoint {
 343 2 dict begin
 344    gtransform
 345    /y exch yscale def
 346    /x exch xscale def
 347    v@ct_I x mulv
 348    v@ct_J y mulv
 349    addv
 350 end
 351 } def
 352
 353 /rptojpoint {
 354    xtranslate ytranslate
 355    3 1 roll         %% xA yB yA xB
 356    4 1 roll         %% xB xA yB yA
 357    sub neg 3 1 roll %% yB-yA xB xA
 358    sub neg exch
 359    ptojpoint
 360 } def
 361
 362 /rptoppoint {
 363    xtranslate ytranslate
 364    3 1 roll         %% xA yB yA xB
 365    4 1 roll         %% xB xA yB yA
 366    sub neg 3 1 roll %% yB-yA xB xA
 367    sub neg exch
 368 } def
 369
 370 /ptojpoint {
 371 4 dict begin
 372    /Y exch yscale-1 def
 373    /X exch xscale-1 def
 374    /y Y yunit angle_repere sin mul div def
 375    /x X y yunit mul angle_repere cos mul sub xunit div def
 376    x y
 377    gtransform-1
 378 end
 379 } def
 380
 381 /smoveto {
 382    jtoppoint
 383    moveto
 384 } def
 385
 386 /srmoveto {
 387    jtoppoint
 388    rmoveto
 389 } def
 390
 391 /slineto {
 392    jtoppoint
 393    lineto
 394 } def
 395
 396 /srlineto {
 397    jtoppoint
 398    rlineto
 399 } def
 400
 401 /stranslate {
 402    jtoppoint
 403    translate
 404 } def
 405
 406 %%%%% ### fin insertion ###
 407
 408 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 409 %%%%            methodes numeriques                     %%%%
 410 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 411
 412 %%%%% ### solve2nddegre ###
 413 %% syntaxe : a b c solve2nddegre --> x1 x2
 414 /solve2nddegre {
 415 5 dict begin
 416    /@c exch def
 417    /@b exch def
 418    /@a exch def
 419    /delt@ @b dup mul 4 @a mul @c mul sub def
 420    @b neg delt@ sqrt sub 2 @a mul div
 421    @b neg delt@ sqrt add 2 @a mul div
 422 end
 423 } def
 424
 425 %%%%% ### fin insertion ###
 426
 427 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 428 %%%%                  la 2D                             %%%%
 429 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 430
 431 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 432 %%%%                  points                            %%%%
 433 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 434
 435 %%%%% ### tripointangle ###
 436 %% syntaxe : A B C tripointangle --> angle ABC
 437 /tripointangle {
 438 9 dict begin
 439    /yC exch def
 440    /xC exch def
 441    /yB exch def
 442    /xB exch def
 443    /yA exch def
 444    /xA exch def
 445    /A {xA yA} def
 446    /B {xB yB} def
 447    /C {xC yC} def
 448    B C angle
 449    B A angle
 450    sub
 451 end
 452 } def
 453
 454 %%%%% ### angle ###
 455 %% syntaxe : A B angle
 456 %% --> num, l'angle defini par le vecteur AB dans le repere orthonorme jps
 457 /angle {
 458    vecteur exch atan
 459    dup 180 gt
 460       {360 sub}
 461    if
 462 } def
 463
 464 %% syntaxe : A B pangle
 465 %% --> num, l'angle defini par le vecteur AB dans le repere postscript
 466 /pangle {
 467    jtoppoint exchp jtoppoint exchp vecteur exch atan
 468    dup 180 gt
 469          {360 sub}
 470    if
 471 } def
 472
 473 %%%%% ### setxrange ###
 474 /setxrange {
 475    /xmax exch def
 476    /xmin exch def
 477 } def
 478
 479 %%%%% ### setyrange ###
 480 /setyrange {
 481    /ymax exch def
 482    /ymin exch def
 483 } def
 484
 485 %%%%% ### defpoint ###
 486 %% syntaxe : xA yA /A defpoint
 487 /defpoint {
 488 1 dict begin
 489    /t@mp@r@ire exch def
 490    [ 3 1 roll ] cvx t@mp@r@ire exch
 491 end def
 492 } def
 493
 494 %%%%% ### milieu ###
 495 %% syntaxe~: A B milieu
 496 /milieu {
 497                 %% xA yA xB yB
 498    3 -1 roll    %% xA xB yB yA
 499    add 2 div    %% xA xB yM
 500    3 1 roll     %% yM xA xB
 501    add 2 div    %% yM xM
 502    exch
 503 } def
 504
 505 %%%%% ### parallelopoint ###
 506 %% syntaxe : A B C parallelopoint --> point D, tel que ABCD parallelogramme
 507 /parallelopoint {
 508 11 dict begin
 509    /yC exch def
 510    /xC exch def
 511    /yB exch def
 512    /xB exch def
 513    /yA exch def
 514    /xA exch def
 515    /A {xA yA} def
 516    /B {xB yB} def
 517    /C {xC yC} def
 518    /d1 {A B C paral} def
 519    /d2 {B C A paral} def
 520    d1 d2 interdroite
 521 end
 522 } def
 523
 524 %%%%% ### translatepoint ###
 525 %% syntaxe : A u translatepoint --> B image de A par la translation de vecteur u
 526 /translatepoint {
 527    addv
 528 } def
 529
 530 %%%%% ### rotatepoint ###
 531 %% syntaxe : B A r rotatepoint --> C image de B par la rotation de centre A,
 532 %% d'angle r (en degre)
 533 %% En prenant les affixes des pts associes, il vient
 534 %%    (zC - zA) = (zB-zA) e^(ir)
 535 %% soit
 536 %%    zC = (zB-zA) e^(ir) + zA
 537 /rotatepoint {     %% B, A, r
 538    5 copy          %% B, A, r, B, A, r
 539    cos 5 1 roll    %% B, A, r, cos r, B, A
 540    4 1 roll        %% B, A, r, cos r, yA, B, xA
 541    4 1 roll        %% B, A, r, cos r, A, B
 542    vecteur         %% B, A, r, cos r, xB-xA, yB-yA
 543    4 -1 roll sin   %% B, A, cos r, xB-xA, yB-yA, sin r
 544    4 copy mul      %% B, A, cos r, xB-xA, yB-yA, sin r, cos r, xB-xA, (yB-yA) sin r
 545    7 1 roll mul    %% B, A, (yB-yA) sin r, cos r, xB-xA, yB-yA, sin r, cos r (xB-xA)
 546    5 1 roll        %% B, A, (yB-yA) sin r, cos r (xB-xA), cos r, xB-xA, yB-yA, sin r
 547    exch            %% B, A, (yB-yA) sin r, cos r (xB-xA), cos r, xB-xA, sin r, yB-yA
 548    4 -1 roll mul   %% B, A, (yB-yA) sin r, cos r (xB-xA), xB-xA, sin r, (yB-yA)cos r
 549    3 1 roll mul    %% B, A, (yB-yA) sin r, cos r (xB-xA), (yB-yA) cos r, (xB-xA) sin r
 550    add             %% B, A, (yB-yA) sin r, cos r (xB-xA), (yB-yA) cos r +(xB-xA) sin r
 551    3 1 roll        %% B, A, (yB-yA) cos r + (xB-xA) sin r, (yB-yA) sin r, cos r (xB-xA),
 552    exch sub        %% B, A, (yB-yA) cos r + (xB-xA) sin r, cos r (xB-xA)-(yB-yA) sin r
 553    exch            %% B, zA, (zB-zA) e^(ir)
 554    addv
 555    3 -1 roll pop
 556    3 -1 roll pop
 557 } def
 558
 559 %%%%% ### hompoint ###
 560 %% syntaxe : B A alpha hompoint -> le point A' tel que AA' = alpha AB
 561 /hompoint {
 562    5 copy
 563    pop
 564    vecteur      %% vecteur BA
 565    3 -1 roll
 566    neg
 567    mulv   %% alpha x vecteur AB
 568    addv
 569    4 -1 roll
 570    4 -1 roll
 571    pop pop
 572 } def
 573
 574 %%%%% ### orthoproj ###
 575 %% syntaxe : A D orthoproj --> B, le projete orthogonal de A sur D
 576 /orthoproj {
 577    6 -1 roll
 578    6 -1 roll            %% D A
 579    6 copy               %% D A D A
 580    7 -1 roll pop
 581    7 -1 roll pop        %% D D A
 582    perp
 583    interdroite
 584 } def
 585
 586 %% syntaxe : A projx --> le projete orthogonal de A sur Ox
 587 /projx {
 588    pop 0
 589 } def
 590
 591 %% syntaxe : A projy --> le projete orthogonal de A sur Oy
 592 /projy {
 593    exch pop 0 exch
 594 } def
 595
 596 %%%%% ### sympoint ###
 597 %% syntaxe : A I sympoint --> point A', le symetrique de A par rapport
 598 %% au point I
 599 /sympoint {
 600    4 copy
 601    pop pop
 602    vecteur
 603    -2 mulv
 604    addv
 605 } def
 606
 607 %%%%% ### axesympoint ###
 608 %% syntaxe : A D axesympoint --> point B, le symetrique de A par rapport
 609 %% a la droite D
 610 /axesympoint {
 611 2 dict begin
 612    6 copy
 613    pop pop pop pop
 614    /yA exch def
 615    /xA exch def
 616    orthoproj
 617    xA yA vecteur
 618    -2 mulv
 619    xA yA addv
 620 end
 621 } def
 622
 623 %%%%% ### cpoint ###
 624 %% syntaxe : alpha C cpoint -> M, le point du cercle C correspondant a
 625 %% l'angle alpha
 626 /cpoint {           %% a, xI, yI, r
 627 1 dict begin
 628    dup              %% a, xI, yI, r, r
 629    5 -1 roll        %% xI, yI, r, r, a
 630    /alpha exch def
 631    alpha cos mul    %% xI, yI, r, r cos a
 632    exch
 633    alpha sin mul    %% xI, yI, r cos a, r sin a
 634    3 -1 roll add    %% xI, r cos a, yI + r sin a
 635    3 1 roll         %% yI + r sin a, xI, r cos a,
 636    add exch         %% xI + r cos a, yI + r sin a
 637 end
 638 } def
 639
 640 %%%%% ### xdpoint ###
 641 %% x A B xdpoint : le point de la droite (AB) d'abscisse x
 642 /xdpoint {
 643 5 dict begin
 644    /pt2 defpoint
 645    /pt1 defpoint
 646    /x exch def
 647    /a pt1 pt2 coeffdir def
 648    /b pt1 pt2 ordorig def
 649    x dup a mul b add
 650 end
 651 } def
 652
 653 %%%%% ### ydpoint ###
 654 %% y A B ydpoint : le point de la droite (AB) d'ordonnee y
 655 /ydpoint {
 656 5 dict begin
 657    /pt2 defpoint
 658    /pt1 defpoint
 659    /y exch def
 660    pt1 pt2 verticale?
 661       {
 662          pt1 pop y
 663       }
 664       {
 665          /a pt1 pt2 coeffdir def
 666          /b pt1 pt2 ordorig def
 667          y b sub a div y
 668       }
 669    ifelse
 670 end
 671 } def
 672
 673 %%%%% ### ordonnepoints ###
 674 %% syntaxe : xA yA xB yB ordonnepoints --> idem si yB>yA ou si yB=yA
 675 %% avec xB>xA, sinon xB yB xA yA
 676 /ordonnepoints {
 677    4 copy
 678    exch pop             %% ... xA, yA, yB
 679    lt                   %% yA < yB ?
 680       {pop}                     %% oui, c'est fini
 681       {                         %% non : yA >= yB
 682          pop 4 copy
 683          exch pop               %% ... xA, yA, yB
 684          eq                     %% yA = yB ?
 685             {
 686                3 copy                   %% oui, yA = yB
 687                pop pop                  %% ... xA, xB
 688                le                       %% xA =< xB ?
 689                   {}                          %% oui, c'est fini
 690                   {                           %% non, on echange A et B
 691                      4 -1 roll
 692                      4 -1 roll
 693                   }
 694                ifelse
 695             }
 696             {                           %% non : yA < yB => on echange A et B
 697                pop
 698                4 -1 roll
 699                4 -1 roll
 700             }
 701          ifelse
 702       }
 703    ifelse
 704 } def
 705
 706 %%%%% ### distance ###
 707 %% syntaxe~: A B distance
 708 /distance {      %% xA yA xB yB
 709    vecteur       %% x y
 710    dup mul exch  %% y^2 x
 711    dup mul       %% y^2 x^2
 712    add
 713    sqrt
 714 } def
 715
 716 %%%%% ### dup ###
 717 /dupp {2 copy} def
 718 /dupc {3 copy} def
 719 /dupd {4 copy} def
 720
 721 %%%%% ### fin insertion ###
 722 /interdroites {interdroite} def
 723
 724 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 725 %%%%                 vecteurs                           %%%%
 726 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 727
 728 %%%%% ### vecteur ###
 729 %% syntaxe~: A B vecteur
 730 /vecteur {
 731                 %% xA yA xB yB
 732    3 -1 roll    %% xA xB yB yA
 733    sub          %% xA xB yB-yA
 734    3 1 roll     %% yB-yA xA xB
 735    exch sub     %% yB-yA xB-xA
 736    exch
 737 } def
 738
 739 %%%%% ### normalize ###
 740 %% syntaxe : u normalize -> u / ||u||
 741 /normalize {
 742 2 dict begin
 743    /u defpoint
 744    /n u norme def
 745    u 1 n div mulv
 746 end
 747 } def
 748
 749 %%%%% ### addv ###
 750 %% syntaxe : u v addv --> u+v
 751 /addv {         %% xA yA xB yB
 752    3 1 roll     %% xA yB yA xB
 753    4 1 roll     %% xB xA yB yA
 754    add 3 1 roll %% yB+yA xB xA
 755    add exch
 756 } def
 757
 758 %%%%% ### subv ###
 759 %% syntaxe : u v subv --> u - v
 760 /subv { %% xA yA xB yB
 761    -1 mulv
 762    addv
 763 } def
 764
 765 %%%%% ### mulv ###
 766 %% syntaxe : u a mulv --> au
 767 /mulv {   %% xA, yA, a
 768    dup          %% xA, yA, a, a
 769    3 1 roll     %% xA, a, yA, a
 770    mul 3 1 roll %% ayA, xA, a
 771    mul exch
 772 } def
 773
 774 %%%%% ### scalprod ###
 775 %% syntaxe : u v scalprod --> le produit scalaire de u par v
 776 /scalprod {
 777 2 dict begin
 778    /y' exch def
 779    exch
 780    /y exch def
 781    mul y y' mul add
 782 end
 783 } def
 784
 785 %%%%% ### normal ###
 786 %% syntaxe : u normal --> v tel u.v = 0
 787 /normal {
 788    neg exch
 789 } def
 790
 791 %%%%% ### norme ###
 792 %% syntaxe : u norme --> |u|
 793 /norme {
 794    dup mul
 795    exch
 796    dup mul
 797    add sqrt
 798 } def
 799
 800 %%%%% ### oldarrow ###
 801 %% syntaxe : A B oldarrow --> trace fleche en B, direction AB
 802 /oldarrow {
 803 4 dict begin
 804 gsave
 805    /B defpoint
 806    /A defpoint
 807    oldarrowscale scale
 808    oldarrowangle rotate
 809    newpath
 810    B smoveto
 811    A B vecteur normalize /u defpoint
 812    u neg exch /v defpoint
 813    u oldarrowpointe neg mulv rmoveto %% ainsi c'est la pointe qui est en (0, 0)
 814    %% le pt extremal arriere haut
 815       u oldarrowplume neg mulv        %% l'abscisse
 816       v oldarrow@ngle sin oldarrow@ngle cos div oldarrowplume mul mulv addv %% l'ordonnee
 817    rlineto
 818       u oldarrowplume oldarrowpointe add mulv
 819       v oldarrow@ngle sin oldarrow@ngle cos div oldarrowplume mul neg mulv addv
 820    rlineto
 821       u oldarrowplume oldarrowpointe add neg mulv
 822       v oldarrow@ngle sin oldarrow@ngle cos div oldarrowplume mul neg mulv addv
 823    rlineto
 824    closepath Fill
 825 grestore
 826 end
 827 } def
 828
 829 /oldarrowpointe {xunit 5 div} def
 830 /oldarrowplume {xunit 10 div} def
 831 /oldarrow@ngle 45 def
 832 /oldarrowscale {1 1} def
 833 /oldarrowangle 0 def     %% pour l'utilisateur
 834
 835 %%%%% ### drawvecteur ###
 836 %% syntaxe : A B drawvecteur
 837 /drawvecteur {
 838 2 dict begin
 839    /B defpoint
 840    /A defpoint
 841    [A B] ligne
 842    A B oldarrow
 843 end
 844 } def
 845
 846 %%%%% ### orthovecteur ###
 847 %% syntaxe : u orthovecteur --> v, vecteur orthogonal a u
 848 /orthovecteur {
 849    neg exch
 850 } def
 851
 852 %%%%% ### fin insertion ###
 853
 854 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 855 %%%%                  cercles                           %%%%
 856 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 857
 858 %%%%% ### defcercle ###
 859 %% syntaxe : A r /d defcercle
 860 /defcercle {
 861 1 dict begin
 862    /t@mp@r@ire exch def
 863    [ 4 1 roll ] cvx t@mp@r@ire exch
 864 end def
 865 } def
 866
 867 %%%%% ### interdroitecercle ###
 868 %% intersection de la droite y = ax+b avec le cercle (x-x0)^2 + (y-y0)^2 = r^2
 869 %% { --       b - y                   2          2           3
 870 %% { |  x = - -----, y = (b + a x0 + a  y0 + (2 a  b y0 - 2 a  b x0 +
 871 %% { --         a
 872 %%
 873 %%       3          2  2    2  2    4  2    2   2    4   2             2
 874 %%    2 a  x0 y0 - a  b  + a  r  + a  r  - a  y0  - a  x0 )^(1/2)) / (a  + 1)
 875 %%
 876 %%
 877 %%    --
 878 %%     |,
 879 %%    --
 880 %%     --       b - y                   2          2           3
 881 %%     |  x = - -----, y = (b + a x0 + a  y0 - (2 a  b y0 - 2 a  b x0 +
 882 %%     --         a
 883 %%
 884 %%       3          2  2    2  2    4  2    2   2    4   2             2
 885 %%    2 a  x0 y0 - a  b  + a  r  + a  r  - a  y0  - a  x0 )^(1/2)) / (a  + 1)
 886 %%
 887 %%    -- }
 888 %%     | }
 889 %%    -- }
 890
 891 %% intersection de la droite x = a avec le cercle (x-x0)^2 + (y-y0)^2 = r^2
 892 %%                              2    2     2 1/2
 893 %% {[x = a, y = y0 + (2 a x0 - a  + r  - x0 )   ],
 894 %%
 895 %%                                2    2     2 1/2
 896 %%    [x = a, y = y0 - (2 a x0 - a  + r  - x0 )   ]}
 897
 898 %% intersection de la droite y = b avec le cercle (x-x0)^2 + (y-y0)^2 = r^2
 899 %%                              2    2     2 1/2
 900 %% {[y = b, x = x0 + (2 b y0 - b  + r  - y0 )   ],
 901 %%
 902 %%                                2    2     2 1/2
 903 %%    [y = b, x = x0 - (2 b y0 - b  + r  - y0 )   ]}
 904
 905 %% syntaxe : D I r interdroitecercle
 906 /interdroitecercle {
 907 16 dict begin
 908    /r exch def
 909    /y0 exch def
 910    /x0 exch def
 911    /yB exch def
 912    /xB exch def
 913    /yA exch def
 914    /xA exch def
 915
 916    xA yA xB yB verticale?
 917
 918    %% la droite est verticale
 919    {
 920       /xpt1 xA def
 921       /xpt2 xA def
 922       /quantite
 923          2 xA mul x0 mul xA dup mul sub r dup mul add x0 dup mul sub sqrt
 924       def
 925       /ypt1
 926          y0 quantite add
 927       def
 928       /ypt2
 929          y0 quantite sub
 930       def
 931    }
 932
 933    %% la droite n'est pas verticale
 934    {
 935       /a xA yA xB yB coeffdir def
 936       /b xA yA xB yB ordorig def
 937
 938       0 a eq
 939       %% la droite est horizontale
 940       {
 941          /quantite
 942             2 b mul y0 mul
 943             b dup mul sub
 944             r dup mul add
 945             y0 dup mul sub
 946             sqrt
 947          def
 948          /xpt1
 949             x0 quantite add
 950          def
 951          /xpt2
 952             x0 quantite sub
 953          def
 954          /ypt1 b def
 955          /ypt2 b def
 956       }
 957
 958       %% la droite n'est pas horizontale
 959       {
 960          /quantite1
 961             b
 962             a x0 mul add
 963             a dup mul y0 mul add
 964          def
 965          /quantite2
 966             2 a dup mul mul b mul y0 mul
 967             2 a 3 exp mul b mul x0 mul sub
 968             2 a 3 exp mul x0 mul y0 mul add
 969             a dup mul b dup mul mul sub
 970             a dup mul r dup mul mul add
 971             a 4 exp r dup mul mul add
 972             a dup mul y0 dup mul mul sub
 973             a 4 exp x0 dup mul mul sub
 974             sqrt
 975          def
 976          /quantite3
 977             a dup mul 1 add
 978          def
 979          /ypt1
 980             quantite1 quantite2 add quantite3 div
 981          def
 982          /xpt1
 983             ypt1 b sub a div
 984          def
 985          /ypt2
 986             quantite1 quantite2 sub quantite3 div
 987          def
 988          /xpt2
 989             ypt2 b sub a div
 990          def
 991       }
 992       ifelse
 993    }
 994    ifelse
 995
 996    xpt1 ypt1
 997    xpt2 ypt2
 998    ordonnepoints
 999 end
1000 } def
1001
1002 %%%%% ### intercercle ###
1003 %% syntaxe : cerc1 cerc2 intercercle --> A B les points d'intersection
1004 %% des 2 cercles, tries par 'ordonnepoints'
1005 /intercercle {
1006 12 dict begin
1007    /r2 exch def
1008    /y2 exch def
1009    /x2 exch def
1010    /r1 exch def
1011    /y1 exch def
1012    /x1 exch def
1013
1014    %% on translate pour se ramener a (x1, y1) = (0, 0)
1015    x2 y2 x1 y1 subv
1016    /y2 exch def
1017    /x2 exch def
1018
1019    %% on prepare l'equation du 2nd degre
1020
1021 %%                    2       2    2
1022 %%   {y = RootOf((4 x2  + 4 y2 ) _Z
1023 %%
1024 %%                  3        2              2       2            4
1025 %%          + (-4 y2  - 4 r1~  y2 + 4 y2 r2~  - 4 x2  y2) _Z + x2
1026 %%
1027 %%               4       2    2       2   2       2    2        2   2
1028 %%          + r2~  - 2 y2  r2~  + 2 x2  y2  - 2 x2  r2~  - 2 r1~  x2
1029 %%
1030 %%               4     4        2   2        2    2
1031 %%          + r1~  + y2  + 2 r1~  y2  - 2 r1~  r2~ ), x = 1/2 (-2 y2
1032 %%
1033 %%                     2       2    2
1034 %%         RootOf((4 x2  + 4 y2 ) _Z
1035 %%
1036 %%                  3        2              2       2            4
1037 %%          + (-4 y2  - 4 r1~  y2 + 4 y2 r2~  - 4 x2  y2) _Z + x2
1038 %%
1039 %%               4       2    2       2   2       2    2        2   2
1040 %%          + r2~  - 2 y2  r2~  + 2 x2  y2  - 2 x2  r2~  - 2 r1~  x2
1041 %%
1042 %%               4     4        2   2        2    2       2     2     2
1043 %%          + r1~  + y2  + 2 r1~  y2  - 2 r1~  r2~ ) + r1~  + x2  + y2
1044 %%
1045 %%               2
1046 %%          - r2~ )/x2}
1047
1048    %% coeff pour le degre 2
1049    /a
1050       %%                    2       2    2
1051       %%   {y = RootOf((4 x2  + 4 y2 ) _Z
1052       4 x2 dup mul mul
1053       4 y2 dup mul mul add
1054    def
1055
1056    %% coeff pour le degre 1
1057    %%
1058    /b
1059       %%                    3        2              2       2
1060       %%            + (-4 y2  - 4 r1~  y2 + 4 y2 r2~  - 4 x2  y2) _Z
1061       -4 y2 3 exp mul
1062       4 r1 dup mul mul y2 mul sub
1063       4 r2 dup mul mul y2 mul add
1064       4 x2 dup mul mul y2 mul sub
1065    def
1066
1067    %% coeff pour le degre 0
1068    %%
1069    /c {
1070       %%              4
1071       %%          + x2
1072       x2 4 exp
1073       %%
1074       %%               4       2    2       2   2       2    2        2   2
1075       %%          + r2~  - 2 y2  r2~  + 2 x2  y2  - 2 x2  r2~  - 2 r1~  x2
1076       r2 4 exp add
1077       2 y2 dup mul mul r2 dup mul mul sub
1078       2 x2 dup mul mul y2 dup mul mul add
1079       2 x2 dup mul mul r2 dup mul mul sub
1080       2 x2 dup mul mul r1 dup mul mul sub
1081       %%
1082       %%               4     4        2   2        2    2
1083       %%          + r1~  + y2  + 2 r1~  y2  - 2 r1~  r2~ )
1084       r1 4 exp add
1085       y2 4 exp add
1086       2 r1 dup mul mul y2 dup mul mul add
1087       2 r1 dup mul mul r2 dup mul mul sub
1088    } def
1089
1090    a b c solve2nddegre
1091    /Y1 exch def
1092    /Y0 exch def
1093
1094    /X0
1095       %% x = 1/2 (-2 y2  Y
1096       -2 y2 mul Y0 mul
1097       %%
1098       %%        2     2     2
1099       %% + r1~  + x2  + y2
1100       r1 dup mul add
1101       x2 dup mul add
1102       y2 dup mul add
1103       %%
1104       %%                 2
1105       %%            - r2~ )/x2}
1106       r2 dup mul sub
1107
1108       2 x2 mul div
1109    def
1110
1111    /X1
1112       %% x = 1/2 (-2 y2  Y
1113       -2 y2 mul Y1 mul
1114       %%
1115       %%        2     2     2
1116       %% + r1~  + x2  + y2
1117       r1 dup mul add
1118       x2 dup mul add
1119       y2 dup mul add
1120       %%
1121       %%                 2
1122       %%            - r2~ )/x2}
1123       r2 dup mul sub
1124
1125       2 x2 mul div
1126    def
1127
1128    %% on depose le resultat, en n'oubliant pas de retranslater en sens
1129    %% inverse
1130
1131    X0 Y0 x1 y1 addv
1132    X1 Y1 x1 y1 addv
1133    ordonnepoints
1134 end
1135 } def
1136
1137 %%%%% ### ABcercle ###
1138 %% syntaxe : A B C ABcercle --> le cercle passant par A, B, C
1139 /ABcercle {
1140 3 dict begin
1141    /@3 defpoint
1142    /@2 defpoint
1143    /@1 defpoint
1144    @1 @2 mediatrice
1145    @1 @3 mediatrice
1146    interdroite
1147    dupp
1148    @3 distance
1149 end
1150 } def
1151
1152 %%%%% ### diamcercle ###
1153 %% syntaxe : A B diamcercle --> le cercle de diametre [AB]
1154 /diamcercle {
1155    4 copy
1156    distance 2 div
1157    5 1 roll
1158    milieu
1159    3 -1 roll
1160 } def
1161
1162 %%%%% ### fin insertion ###
1163
1164 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1165 %%%%                  droites                           %%%%
1166 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1167
1168 %%%%% ### horizontale ###
1169 %% syntaxe : y horizontale
1170 /horizontale {
1171 1 dict begin
1172    /y exch def
1173    xmin y xmax y
1174 end
1175 } def
1176
1177 %%%%% ### coeffdir ###
1178 %% syntaxe~: A B coeffdir
1179 /coeffdir {
1180    vecteur exch div
1181 } def
1182
1183 %%%%% ### ordorig ###
1184 %% syntaxe : A B ordorig
1185 %% attention, la droite est supposee ne pas etre verticale
1186 /ordorig {
1187    /dr@ite 4 array def
1188    dr@ite 3 3 -1 roll put
1189    dr@ite 2 3 -1 roll put
1190    dr@ite 1 3 -1 roll put
1191    dr@ite 0 3 -1 roll put
1192    dr@ite aload pop coeffdir /c@eff exch def
1193    dr@ite aload pop pop pop  %% xA yA
1194    exch                      %% yA xA
1195    c@eff mul neg add
1196 } def
1197
1198 %%%%% ### verticale ###
1199 %% syntaxe~: A B verticale?
1200 /verticale? {
1201    pop 2 1 roll pop
1202    eq
1203 } def
1204
1205 %% syntaxe : x verticale
1206 /verticale {
1207 1 dict begin
1208    /x exch def
1209    x ymin x ymax
1210 end
1211 } def
1212
1213 %%%%% ### droite ###
1214 %% %% syntaxe : A B droite
1215 %% /droite {
1216 %% gsave
1217 %% 6 dict begin
1218 %%    /yB exch def
1219 %%    /xB exch def
1220 %%    /yA exch def
1221 %%    /xA exch def
1222 %%    xA yA xB yB
1223 %%    eqp
1224 %%       {}
1225 %%       {
1226 %%          xA yA xB yB
1227 %%       verticale?
1228 %%       {
1229 %%       newpath
1230 %%          xA ymin smoveto
1231 %%          xA ymax slineto
1232 %%             stockcurrentcpath
1233 %%       stroke
1234 %%       }
1235 %%       {
1236 %%       newpath
1237 %%          /alpha xA yA xB yB coeffdir def
1238 %%          /beta xA yA xB yB ordorig def
1239 %%          xmin dup alpha mul beta add smoveto
1240 %%          xmax dup alpha mul beta add slineto
1241 %%             stockcurrentcpath
1242 %%       stroke
1243 %%       }
1244 %%       ifelse
1245 %%       }
1246 %%    ifelse
1247 %% end
1248 %% grestore
1249 %% } def
1250
1251 %% syntaxe : A B droite
1252 /droite {
1253 gsave
1254 6 dict begin
1255    /B defpoint
1256    /A defpoint
1257    A pop B pop eq {
1258       %% droite verticale
1259       newpath
1260          A pop ymin smoveto
1261          A pop ymax slineto
1262          stockcurrentcpath
1263       Stroke
1264    } {
1265       %% on cherche le point le + a gauche
1266       xmin A B xdpoint /C defpoint
1267       C exch pop ymin lt {
1268          %% trop a gauche
1269          ymin A B ydpoint /C defpoint
1270       } if
1271       C exch pop ymax gt {
1272          %% trop a gauche
1273          ymax A B ydpoint /C defpoint
1274       } if
1275       %% on cherche le point le + a droite
1276       xmax A B xdpoint /D defpoint
1277       D exch pop ymin lt {
1278          %% trop a droite
1279          ymin A B ydpoint /D defpoint
1280       } if
1281       D exch pop ymax gt {
1282          %% trop a gauche
1283          ymax A B ydpoint /D defpoint
1284       } if
1285       newpath
1286          C smoveto
1287          D slineto
1288          stockcurrentcpath
1289      Stroke
1290    } ifelse
1291 end
1292 grestore
1293 } def
1294
1295 %%%%% ### defdroite ###
1296 %% syntaxe : A B /d defdroite
1297 /defdroite {
1298 1 dict begin
1299    /t@mp@r@ire exch def
1300    [ 5 1 roll ] cvx t@mp@r@ire exch
1301 end def
1302 } def
1303
1304 %%%%% ### paral ###
1305 %% syntaxe : D A paral --> droite parallele a D passant par A
1306 /paral {
1307 4 dict begin
1308    /yA exch def
1309    /xA exch def
1310    vecteur
1311    /u2 exch def
1312    /u1 exch def
1313    xA yA
1314    2 copy
1315    u1 u2 translatepoint
1316 end
1317 } def
1318
1319 %%%%% ### interdroite ###
1320 /interdroite {
1321                 %% A B C D
1322    /dr@ite2 4 array def
1323    dr@ite2 3 3 -1 roll put
1324    dr@ite2 2 3 -1 roll put
1325    dr@ite2 1 3 -1 roll put
1326    dr@ite2 0 3 -1 roll put
1327    /dr@ite1 4 array def
1328    dr@ite1 3 3 -1 roll put
1329    dr@ite1 2 3 -1 roll put
1330    dr@ite1 1 3 -1 roll put
1331    dr@ite1 0 3 -1 roll put
1332
1333 %%%    %% trace pour deboguage
1334 %%%    dr@ite1 aload pop droite
1335 %%%    dr@ite2 aload pop droite
1336
1337 %%% Dans tous les cas, on suppose que l'intersection existe
1338 %%%
1339 %%% * la 1ere droite est verticale. les equations reduites sont
1340 %%%       x = a1      et       y = a2 x + b2
1341 %%% Le point d'intersection est :
1342 %%%       {{x = a1, y = b2 + a1 a2}}
1343 %%%
1344 %%% * la 2eme droite est verticale. les equations reduites sont
1345 %%%       x = a1 x+ b1     et       x = a2
1346 %%% Le point d'intersection est :
1347 %%%       {{x = a2, y = b1 + a1 a2}}
1348 %%%
1349 %%% * aucune n'est verticale. Les equations reduites sont
1350 %%%       y = a1 x + b1      et       y = a2 x + b2
1351 %%% Le point d'intersection est :
1352 %%%                 { {     b2 - b1      a1 b2 - a2 b1 } }
1353 %%%                 { { x = -------, y = ------------- } }
1354 %%%                 { {     a1 - a2         a1 - a2    } }
1355
1356 %%% remarque : pour le moment, je n'arrive pas a rendre mes variables
1357 %%% locales : elle restent globales. Pour que cela ne soit pas trop
1358 %%% genant, je les note respectivement @1, @@1, @2 et @@2 au lieu de a1,
1359 %%% b1, a2 et b2.
1360
1361    dr@ite1 aload pop verticale?
1362       {
1363          /@1 {dr@ite1 aload pop pop pop pop} def
1364          /@2 {dr@ite2 aload pop coeffdir} def
1365          /@@2 {dr@ite2 aload pop ordorig} def
1366          @1
1367          @1 @2 mul @@2 add
1368       }
1369       {
1370       dr@ite2 aload pop verticale?
1371          {
1372             /@1 {dr@ite1 aload pop coeffdir} def
1373             /@@1 {dr@ite1 aload pop ordorig} def
1374             /@2 {dr@ite2 aload pop pop pop pop} def
1375             @2
1376             @1 @2 mul @@1 add
1377          }
1378          {
1379             /@1 {dr@ite1 aload pop coeffdir} def
1380             /@@1 {dr@ite1 aload pop ordorig} def
1381             /@2 {dr@ite2 aload pop coeffdir} def
1382             /@@2 {dr@ite2 aload pop ordorig} def
1383             @@2 @@1 sub @1 @2 sub div
1384             @1 @@2 mul @2 @@1 mul sub
1385             @1 @2 sub div
1386          }
1387       ifelse
1388       }
1389    ifelse
1390 } def
1391
1392 %%%%% ### perp ###
1393 %% syntaxe : D A perp --> droite perpendiculaire a D passant par A
1394 /perp {
1395 4 dict begin
1396    /yA exch def
1397    /xA exch def
1398    vecteur orthovecteur
1399    /u2 exch def
1400    /u1 exch def
1401    xA yA
1402    2 copy
1403    u1 u2 translatepoint
1404 end
1405 } def
1406
1407 %%%%% ### mediatrice ###
1408 %% synaxe : A B mediatrice --> droite
1409 /mediatrice {
1410    4 copy
1411    milieu
1412    perp
1413 } def
1414
1415 %%%%% ### bissectrice ###
1416 %% syntaxe : A B C bissectrice --> B E ou E est un point de la bissectrice
1417 /bissectrice {
1418 10 dict begin
1419    /yC exch def
1420    /xC exch def
1421    /yB exch def
1422    /xB exch def
1423    /yA exch def
1424    /xA exch def
1425    /A {xA yA} def
1426    /B {xB yB} def
1427    /C {xC yC} def
1428    /alpha {A B C tripointangle} def
1429    B
1430    A B alpha rotatepoint
1431    A milieu
1432 end
1433 } def
1434
1435 %%%%% ### angledroit  ###
1436  /widthangledroit 5 def
1437
1438 %% syntaxe : A B C angledroit --> dessine un angle droit en B
1439 /angledroit {
1440 10 dict begin
1441    dup xcheck {
1442       /widthangledroit exch def
1443    } if
1444    /C defpoint
1445    /B defpoint
1446    /A defpoint
1447    B C vecteur normalize widthangledroit 20 div mulv /u defpoint
1448    B A vecteur normalize widthangledroit 20 div mulv /v defpoint
1449    [B u addv dupp v addv B v addv] ligne
1450 end
1451 } def
1452
1453 %%%%% ### translatedroite ###
1454 %% syntaxe : A B u translatedroite --> C D images resp de A et B par la translation de vecteur u
1455 /translatedroite {         %% A B u
1456    2 copy          %% A B u u
1457    6 1 roll
1458    6 1 roll        %% A u B u
1459    addv      %% A u D
1460    6 1 roll
1461    6 1 roll        %% D A u
1462    addv
1463    4 1 roll
1464    4 1 roll
1465 } def
1466
1467 %%%%% ### rotatedroite ###
1468 %% syntaxe : A B O r rotatedroite --> C D images resp de A et B par la
1469 %% rotation de centre O et d'angle r (en degre)
1470 /rotatedroite {
1471    5 copy rotatepoint   %% A B O r D
1472    6 -1 roll pop        %% A xB O r D
1473    6 -1 roll pop        %% A O r D
1474    7 1 roll
1475    7 1 roll rotatepoint %% D C
1476    4 1 roll 4 1 roll
1477 } def
1478
1479 /rotatevecteur {
1480    rotatedroite
1481 } def
1482
1483 /rotatesegment {
1484    rotatedroite
1485 } def
1486
1487 %%%%% ### axesymdroite ###
1488 %% syntaxe : d D axesymdroite --> droite d', symetrique de la droite d par rapport
1489 %% a la droite D
1490 /axesymdroite {
1491 2 dict begin
1492    /D defdroite
1493    /B defpoint
1494    D axesympoint
1495    B D axesympoint
1496 end
1497 } def
1498
1499 %%%%% ### fin insertion ###
1500
1501 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1502 %%%%                  polygones                         %%%%
1503 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1504
1505 %%%%% ### poltransformfile ###
1506 %% syntaxe : pol u translatepol --> pol'
1507 /translatepol {
1508 2 dict begin
1509    /uy exch def
1510    /ux exch def
1511    {ux uy translatepoint} papply
1512 end
1513 } def
1514
1515 %% syntaxe : pol u rotatepol --> pol'
1516 /rotatepol {
1517 2 dict begin
1518    /alpha exch def
1519    /I defpoint
1520    {I alpha rotatepoint} papply
1521 end
1522 } def
1523
1524 %% syntaxe : pol I alpha hompol --> pol'
1525 /hompol {
1526 2 dict begin
1527    /alpha exch def
1528    /I defpoint
1529    {I alpha hompoint} papply
1530 end
1531 } def
1532
1533 %% syntaxe : pol I sympol --> pol'
1534 /sympol {
1535 1 dict begin
1536    /I defpoint
1537    {I sympoint} papply
1538 end
1539 } def
1540
1541 %% syntaxe : pol D axesympol --> pol'
1542 /axesympol {
1543 1 dict begin
1544    /D defdroite
1545    {D axesympoint} papply
1546 end
1547 } def
1548
1549 %%%%% ### fin insertion ###
1550
1551 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1552 %%%%                  les tests                         %%%%
1553 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1554
1555 %%%%% ### isbool ###
1556 %% syntaxe : any isbool --> booleen
1557 /isbool {
1558    type (booleantype) cvn eq
1559 } def
1560
1561 %%%%% ### isarray ###
1562 %% syntaxe : any isarray --> booleen
1563 /isarray {
1564    type (arraytype) cvn eq
1565 } def
1566
1567 %%%%% ### isstring ###
1568 %% syntaxe : any isstring --> booleen
1569 /isstring {
1570    type (stringtype) cvn eq
1571 } def
1572
1573 %%%%% ### isinteger ###
1574 %% syntaxe : any isinteger --> booleen
1575 /isinteger {
1576    type (integertype) cvn eq
1577 } def
1578
1579 %%%%% ### isnum ###
1580 %% syntaxe : any isnum --> booleen
1581 /isnum {
1582    dup isreal
1583    exch isinteger or
1584 } def
1585
1586 %%%%% ### isreal ###
1587 %% syntaxe : any isreal --> booleen
1588 /isreal {
1589    type (realtype) cvn eq
1590 } def
1591
1592 %%%%% ### eq ###
1593 %% syntaxe : A B eqp3d --> booleen = true si les points A et B sont identiques
1594 /eqp3d {
1595                %% x1 y1 z1 x2 y2 z2
1596    4 -1 roll   %% x1 y1 x2 y2 z2 z1
1597    eq {        %% x1 y1 x2 y2
1598       eqp
1599    } {
1600       pop pop pop pop false
1601    } ifelse
1602 } def
1603
1604 %% syntaxe : A B eqp --> booleen = true si les points A et B sont identiques
1605 /eqp {
1606    3 -1 roll
1607    eq
1608       {
1609          eq
1610             {true}
1611             {false}
1612          ifelse
1613       }
1614       {pop pop false}
1615    ifelse
1616 } def
1617
1618 %% syntaxe : z z' eqc --> true si z = z', false sinon
1619 /eqc {
1620    eqp
1621 } def
1622
1623 %%%%% ### eqstring ###
1624 /eqstring {
1625 3 dict begin
1626    /str2 exch def
1627    /str1 exch def
1628    str1 length str2 length eq {
1629       /i 0 def
1630       true
1631       str1 length {
1632          str1 i get str2 i get eq and
1633          /i i 1 add store
1634       } repeat
1635    } {
1636       false
1637    } ifelse
1638 end
1639 } def
1640
1641 %%%%% ### fin insertion ###
1642
1643 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1644 %%%%                conversions de types                %%%%
1645 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1646
1647 %%%%% ### astr2str ###
1648 %% syntaxe : array str astr2str --> str
1649 %% convertit le contenu de array en chaines de caracteres puis les
1650 %% concatene avec str, en inserant un caractere "space" apres chaque
1651 %% element du tableau array
1652 /astr2str {
1653 5 dict begin
1654    /str exch def
1655    /table exch def
1656    /n table length def
1657    n 0 eq {
1658       str
1659    } {
1660       table 0 n 1 sub getinterval
1661       table n 1 sub get (                               ) cvs
1662       ( ) append
1663       str append
1664       astr2str
1665    } ifelse
1666 end
1667 } def
1668
1669 %%%%% ### numstr2array ###
1670 %% syntaxe : str str2num --> num
1671 /str2num {
1672 5 dict begin
1673    /str exch def
1674    /n str length def
1675    /signnum 1 def
1676    /frct false def
1677    /k 0 def
1678    0 1 n 1 sub {
1679       /i exch def
1680       str i get
1681       dup 46 eq {
1682          %% il y a un point
1683          /frct true def
1684          pop
1685          i 0 eq {
1686             0
1687          } if
1688       } {
1689          dup 45 eq {
1690             /signnum -1 def
1691             pop
1692          } {
1693             frct not {
1694                i 1 ge signnum 0 ge and i 2 ge or {
1695                   exch 10 mul 48 sub add
1696                } {
1697                   48 sub
1698                } ifelse
1699             } {
1700                48 sub
1701                /k k 1 add store
1702                10 k exp div add
1703             } ifelse
1704          } ifelse
1705       } ifelse
1706    } for
1707    signnum mul
1708 end
1709 } def
1710
1711 /str2num {cvx exec} def
1712
1713 %% syntaxe : str numstr2array -> array
1714 %% ou str est une chaine de nombres reels separes par des espaces
1715 %% et array est constitue des elements numeriques de string.
1716 %% exemple :
1717 %% (0 -12 .234 54) --> [0 -12 0.234 54]
1718 /numstr2array {
1719 6 dict begin
1720    /str exch def
1721    /n str length def
1722    /separateurs [] def
1723    [
1724       0 1 n 1 sub {
1725          /i exch def
1726          str i get
1727          32 eq {
1728             /separateurs [separateurs aload pop i] def
1729          } if
1730       } for
1731       /j 0 def
1732       /oldsep 0 def
1733       0 1 separateurs length 1 sub {
1734          /i exch def
1735          str j separateurs i get oldsep sub getinterval str2num
1736          /j separateurs i get 1 add def
1737          /oldsep separateurs i get 1 add def
1738       } for
1739       str j n oldsep sub getinterval str2num
1740    ]
1741 end
1742 } def
1743
1744 %% syntaxe : array numstr2array -> array
1745 /arraynumstr2arrayarray {
1746    {numstr2array} apply
1747 } def
1748
1749 %%%%% ### fin insertion ###
1750
1751 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1752 %%%%                macros de projection                %%%%
1753 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1754
1755 %%%%% ### projtext ###
1756 %% syntaxe : str x0 y0 z0 [normal_vect] ultextp3d --> -
1757 %% syntaxe : str x0 y0 z0 [normal_vect] bool ultextp3d --> -
1758 %% syntaxe : str x0 y0 plantype ultextp3d --> -
1759 %% syntaxe : str x0 y0 plantype bool ultextp3d --> -
1760 %% syntaxe : str1 solid i str2 ultextp3d --> -
1761 %% syntaxe : str1 solid i str2 bool ultextp3d --> -
1762 %% syntaxe : str1 solid i alpha str2 bool ultextp3d --> -
1763  /initpr@jtext {
1764 5 dict begin
1765    dup isbool {
1766       /mybool exch def
1767    } {
1768       /mybool true def
1769    } ifelse
1770    dup isplan {
1771       /type_plan_proj true def
1772       /lepl@n exch def
1773       lepl@n plangetbase aload pop
1774       /@V defpoint3d
1775       /@U defpoint3d
1776       lepl@n plangetorigine
1777       /z0 exch def
1778       /y0 exch def
1779       /x0 exch def
1780       /table [@U @U @V vectprod3d] def
1781    } {
1782       dup isarray {
1783          %% c est un planprojpath
1784          /type_plan_proj true def
1785          /table exch def
1786          /z0 exch def
1787          /y0 exch def
1788          /x0 exch def
1789          0 0
1790       } {
1791          %% c est un solidprojpath
1792          /type_plan_proj false def
1793          %% y a-t-il un str2
1794          dup isstring {
1795             /str2 exch def
1796          } {
1797             /str2 {} def
1798          } ifelse
1799          %% y a-t-il un alpha
1800          2 copy pop issolid {
1801             /alpha 0 def
1802          } {
1803             /alpha exch def
1804          } ifelse
1805          /i exch def
1806          /solid exch def
1807          0 0
1808       } ifelse
1809    } ifelse
1810 } def
1811  /closepr@jtext {
1812    type_plan_proj {
1813       x0 y0 z0 table mybool projpath
1814    } {
1815       solid i alpha str2 mybool projpath
1816    } ifelse
1817    Fill
1818    Stroke
1819 end
1820 } def
1821
1822 %% syntaxe : str x0 y0 z0 [normal_vect] ultextp3d --> -
1823 %% syntaxe : str x0 y0 z0 [normal_vect] bool ultextp3d --> -
1824 %% syntaxe : str1 solid i str2 ultextp3d --> -
1825 %% syntaxe : str1 solid i str2 bool ultextp3d --> -
1826 %% syntaxe : str1 solid i alpha str2 bool ultextp3d --> -
1827 /ultextp3d {initpr@jtext ultext_ closepr@jtext} def
1828 /cltextp3d {initpr@jtext cltext_ closepr@jtext} def
1829 /bltextp3d {initpr@jtext bltext_ closepr@jtext} def
1830 /dltextp3d {initpr@jtext dltext_ closepr@jtext} def
1831 /ubtextp3d {initpr@jtext ubtext_ closepr@jtext} def
1832 /cbtextp3d {initpr@jtext cbtext_ closepr@jtext} def
1833 /bbtextp3d {initpr@jtext bbtext_ closepr@jtext} def
1834 /dbtextp3d {initpr@jtext dbtext_ closepr@jtext} def
1835 /uctextp3d {initpr@jtext uctext_ closepr@jtext} def
1836 /cctextp3d {initpr@jtext cctext_ closepr@jtext} def
1837 /bctextp3d {initpr@jtext bctext_ closepr@jtext} def
1838 /dctextp3d {initpr@jtext dctext_ closepr@jtext} def
1839 /urtextp3d {initpr@jtext urtext_ closepr@jtext} def
1840 /crtextp3d {initpr@jtext crtext_ closepr@jtext} def
1841 /brtextp3d {initpr@jtext brtext_ closepr@jtext} def
1842 /drtextp3d {initpr@jtext drtext_ closepr@jtext} def
1843
1844 %%%%% ### currentppathtransform ###
1845 %% syntaxe : {f} currentppathtransform --> applique la transformation f
1846 %% au chemin courant
1847 /currentppathtransform {
1848 6 dict begin
1849    /warp exch def
1850    %% pour remplacer 'move'
1851    /warpmove{
1852       2 index {
1853         newpath
1854       } if
1855       warp moveto
1856       pop false
1857    } def
1858
1859    %% pour remplacer 'lineto'
1860    /warpline {
1861       warp lineto
1862    } bind def
1863
1864    %% pour remplacer 'curveto'
1865    /warpcurve {
1866       6 2 roll warp
1867       6 2  roll warp
1868       6 2 roll warp
1869       curveto
1870    }  bind def
1871
1872    true
1873    { warpmove } {  warpline } { warpcurve } { closepath } pathforall
1874    pop
1875 end
1876 } def
1877
1878 %% syntaxe : {f} currentpathtransform --> applique la transformation f
1879 %% au chemin courant
1880 /currentpathtransform {
1881 7 dict begin
1882    /transform exch def
1883    /warp {ptojpoint transform} def
1884    %% pour remplacer 'move'
1885    /warpmove{
1886       2 index {
1887         newpath
1888       } if
1889       warp smoveto
1890       pop false
1891    } def
1892
1893    %% pour remplacer 'lineto'
1894    /warpline {
1895       warp slineto
1896    } bind def
1897
1898    %% pour remplacer 'curveto'
1899    /warpcurve {
1900       6 2 roll warp
1901       6 2  roll warp
1902       6 2 roll warp
1903       scurveto
1904    }  bind def
1905
1906    true
1907    { warpmove } {  warpline } { warpcurve } { closepath } pathforall
1908    pop
1909 end
1910 } def
1911
1912 %%%%% ### normalvect_to_orthobase ###
1913 %% syntaxe : [normal_vect] normalvect_to_orthobase
1914 %%    --> imI imJ imK
1915 /normalvect_to_orthobase {
1916 4 dict begin
1917    dup length 3 eq {
1918       aload pop normalize3d /normal_vect defpoint3d
1919       normal_vect -1 0 0 eqp3d {
1920          /imageI {0 -1 0} def
1921          /imageK {-1 0 0} def
1922          /imageJ {0 0 1} def
1923       } {
1924          %% on calcule l image de la base (I,J,K)
1925          /imageJ {normal_vect 1 0 0 vectprod3d normalize3d} def
1926          /imageK {normal_vect} def
1927          /imageI {imageJ imageK vectprod3d} def
1928          1 0 0 imageK angle3d 0 eq {
1929             0 1 0 normal_vect vectprod3d /imageI defpoint3d
1930             /imageJ {0 1 0} def
1931             normal_vect /imageK defpoint3d
1932          } if
1933       } ifelse
1934    } {
1935       dup length 6 eq {
1936          aload pop
1937          normalize3d /imageK defpoint3d
1938          normalize3d /imageI defpoint3d
1939          imageK imageI vectprod3d /imageJ defpoint3d
1940       } {
1941          dup length 7 eq {
1942             aload pop
1943             /alpha exch 2 div def
1944             normalize3d /imageK defpoint3d
1945             normalize3d /imageI defpoint3d
1946             imageK imageI vectprod3d /imageJ defpoint3d
1947             %% et ensuite, on fait tourner la base autour de imageK
1948             imageI alpha cos mulv3d
1949             imageJ alpha sin mulv3d
1950             addv3d
1951
1952             imageI alpha sin neg mulv3d
1953             imageJ alpha cos mulv3d
1954             addv3d
1955
1956             /imageJ defpoint3d
1957             /imageI defpoint3d
1958          } {
1959             %% length = 4
1960             aload pop
1961             /alpha exch def
1962             normalize3d /normal_vect defpoint3d
1963
1964             normal_vect -1 0 0 eqp3d {
1965                /imageI {0 -1 0} def
1966                /imageK {-1 0 0} def
1967                /imageJ {0 0 1} def
1968             } {
1969                %% on calcule l image de la base (I,J,K)
1970                /imageJ {normal_vect 1 0 0 vectprod3d normalize3d} def
1971                /imageK {normal_vect} def
1972                /imageI {imageJ imageK vectprod3d} def
1973                1 0 0 imageK angle3d 0 eq {
1974                   0 1 0 normal_vect vectprod3d /imageI defpoint3d
1975                   /imageJ {0 1 0} def
1976                   normal_vect /imageK defpoint3d
1977                } if
1978             } ifelse
1979          } ifelse
1980
1981          %% et ensuite, on fait tourner la base autour de imageK
1982          imageI alpha cos mulv3d
1983          imageJ alpha sin mulv3d
1984          addv3d
1985
1986          imageI alpha sin neg mulv3d
1987          imageJ alpha cos mulv3d
1988          addv3d
1989
1990          /imageJ defpoint3d
1991          /imageI defpoint3d
1992       } ifelse
1993    } ifelse
1994    imageI
1995    imageJ
1996    imageK
1997 end
1998 } def
1999
2000 %%%%% ### projpath ###
2001 %% syntaxe : x y z [normal] projpath --> planprojpath
2002 %% syntaxe : x y z [normal] bool projpath --> planprojpath
2003 %% syntaxe : solid i projpath --> solidprojpath
2004 %% syntaxe : solid i bool projpath --> solidprojpath
2005 %% syntaxe : solid i str bool projpath --> solidprojpath
2006 %% syntaxe : solid i alpha str bool projpath --> solidprojpath
2007 /projpath {
2008 2 dict begin
2009    dup isbool {
2010       /mybool exch def
2011    } {
2012       /mybool true def
2013    } ifelse
2014    dup isplan {
2015       3 dict begin
2016          /lepl@n exch def
2017          lepl@n plangetbase aload pop
2018          /@V defpoint3d
2019          /@U defpoint3d
2020          lepl@n plangetorigine
2021          [@U @U @V vectprod3d] mybool planprojpath
2022       end
2023    } {
2024       dup isarray {
2025          mybool planprojpath
2026       } {
2027          mybool solidprojpath
2028       } ifelse
2029    } ifelse
2030 end
2031 } def
2032
2033
2034 %% %% syntaxe : x y z [normal] projpath --> planprojpath
2035 %% %% syntaxe : x y z [normal] bool projpath --> planprojpath
2036 %% %% syntaxe : solid i projpath --> solidprojpath
2037 %% %% syntaxe : solid i bool projpath --> solidprojpath
2038 %% %% syntaxe : solid i str bool projpath --> solidprojpath
2039 %% %% syntaxe : solid i alpha str bool projpath --> solidprojpath
2040 %% /projpath {
2041 %% 2 dict begin
2042 %%    dup isbool {
2043 %%       /mybool exch def
2044 %%    } {
2045 %%       /mybool true def
2046 %%    } ifelse
2047 %%    dup isarray {
2048 %%       mybool planprojpath
2049 %%    } {
2050 %%       mybool solidprojpath
2051 %%    } ifelse
2052 %% end
2053 %% } def
2054 %%
2055 %% syntaxe : solid i str bool solidprojpath --> -
2056 %% ou
2057 %% syntaxe : solid i alpha str bool solidprojpath --> -
2058 %% projette le chemin courant sur la face i du solide, apres
2059 %% eventuellement une rotation d angle alpha autour de la normale
2060 %% bool : pour savoir si on tient compte de la visibilite
2061 /solidprojpath {
2062 5 dict begin
2063    /visibility exch def
2064    dup isstring {
2065       /option exch def
2066    } if
2067    2 copy pop
2068    issolid {
2069       /alpha 0 def
2070    } {
2071       /alpha exch def
2072    } ifelse
2073    /i exch def
2074    /solid exch def
2075    solid issolid not {
2076       (Error : mauvais type d argument dans solidprojpath) ==
2077    } if
2078    /n solid solidnombrefaces def
2079    i n 1 sub le {
2080       visibility not solid i solidfacevisible? or {
2081          currentdict /option known {
2082             option cvx exec
2083          } {
2084             solid i solidcentreface
2085          } ifelse
2086          [
2087             solid 0 i solidgetsommetface
2088             solid 1 i solidgetsommetface
2089             vecteur3d normalize3d
2090             solid i solidnormaleface alpha
2091          ] false planprojpath
2092       } {
2093          newpath 0 0 smoveto
2094       } ifelse
2095    } {
2096       (Error : indice trop grand dans solidprojpath) ==
2097       quit
2098    } ifelse
2099 end
2100 } def
2101
2102 %% syntaxe : x y z [normal] bool planprojpath
2103 /planprojpath {
2104 6 dict begin
2105    /visibility exch def
2106    %% on calcule l image de la base (I,J,K)
2107    normalvect_to_orthobase
2108    /imageK defpoint3d
2109    /imageJ defpoint3d
2110    /imageI defpoint3d
2111    /z exch def
2112    /y exch def
2113    /x exch def
2114
2115    visibility not x y z imageK planvisible? or {
2116       {ptojpoint 0
2117       imageI
2118       imageJ
2119       imageK
2120       transformpoint3d
2121       x y z addv3d
2122       3dto2d jtoppoint} currentppathtransform
2123    } {
2124       newpath
2125    } ifelse
2126 end
2127 } def
2128
2129 %%%%% ### projscene ###
2130 %% syntaxe : plantype bool bprojscene ... eprojscene
2131 /bprojscene {
2132 10 dict begin
2133 gsave
2134    dup isbool {
2135       /mybool exch def
2136    } {
2137       /mybool true def
2138    } ifelse
2139    /l@pl@n exch def
2140    /saveStroke {SolidesDict /Stroke get exec} def
2141    /Stroke {l@pl@n mybool projpath saveStroke} def
2142    /savefill {SolidesDict /Fill get exec} def
2143    /Fill {l@pl@n mybool projpath savefill} def
2144    /masque {} def
2145    l@pl@n plangetrange aload pop
2146    setyrange setxrange
2147    newpath
2148 %%       xmin ymin l@pl@n pointplan smoveto
2149 %%       xmin ymax l@pl@n pointplan slineto
2150 %%       xmax ymax l@pl@n pointplan slineto
2151 %%       xmax ymin l@pl@n pointplan slineto
2152 %%       xmin ymin l@pl@n pointplan smoveto
2153 %%  %   closepath
2154 %% %gsave orange Fill grestore
2155 %%    clip
2156 } def
2157 /eprojscene {
2158 grestore
2159 end
2160 } def
2161
2162 %%%%% ### fin insertion ###
2163
2164 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2165 %%%%          fonctions numeriques                      %%%%
2166 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2167
2168 %%%%% ### courbeparam ###
2169 /setresolution {
2170    /resolution exch def
2171 } def
2172 %/resolution 200 def % ---- hv 20110713
2173
2174 /courbe_dic 2 dict def
2175 courbe_dic /X {} put
2176 courbe_dic /Y {} put
2177
2178 %% syntaxe : tmin tmax C@urbeparam_
2179  /C@urbeparam_ {
2180 6 dict begin
2181    /tmax@ exch def
2182    /tmin@ exch def
2183    /t tmin@ def
2184    /dt tmax@ tmin@ sub resolution 1 sub div def
2185    tmin@ courbe_dic /X get exec
2186    pstrickactionR
2187    tmin@ courbe_dic /Y get exec
2188    pstrickactionR
2189    smoveto
2190    resolution 1 sub
2191    {
2192       t courbe_dic /X get exec
2193       pstrickactionR
2194       t courbe_dic /Y get exec
2195       pstrickactionR
2196       slineto
2197
2198       /t t dt add store                      %% on incremente
2199    }
2200    repeat
2201    tmax@ courbe_dic /X get exec
2202    pstrickactionR
2203    tmax@ courbe_dic /Y get exec
2204    pstrickactionR
2205    slineto
2206 end
2207 } def
2208
2209 %% syntaxe : tmin tmax {X} {Y} Courbeparam_
2210 /Courbeparam_ {
2211    courbe_dic exch /Y exch put
2212    courbe_dic exch /X exch put
2213    C@urbeparam_
2214 } def
2215
2216 %% syntaxe : {X} {Y} courbeparam_
2217 /courbeparam_ {
2218    tmin tmax
2219    4 -1 roll
2220    4 -1 roll
2221    Courbeparam_
2222 } def
2223
2224 %% syntaxe : tmin tmax {X} {Y} Courbeparam
2225 /Courbeparam {
2226 gsave
2227 6 dict begin
2228    dup isstring
2229       {
2230          /option exch def
2231       }
2232    if
2233    courbe_dic exch /Y exch put
2234    courbe_dic exch /X exch put
2235    /tmax exch def
2236    /tmin exch def
2237
2238    newpath
2239       tmin courbe_dic /X get exec
2240       pstrickactionR
2241       tmin courbe_dic /Y get exec
2242       pstrickactionR
2243       smoveto                        %% on commence le chemin
2244       tmin tmax C@urbeparam_
2245       starfill
2246
2247    stockcurrentcpath
2248    newarrowpath
2249    currentdict /option known
2250       {
2251          /dt tmax tmin sub resolution 1 sub div def
2252          tmin dt add courbe_dic /X get exec
2253          tmin dt add courbe_dic /Y get exec
2254          tmin courbe_dic /X get exec
2255          tmin courbe_dic /Y get exec
2256          arrowpath0
2257          tmax dt sub courbe_dic /X get exec
2258          tmax dt sub courbe_dic /Y get exec
2259          tmax courbe_dic /X get exec
2260          tmax courbe_dic /Y get exec
2261          currentdict /dt undef
2262          arrowpath1
2263          option
2264          gere_arrowhead
2265       }
2266    if
2267
2268    currentlinewidth 0 eq {} { Stroke } ifelse
2269
2270 end
2271 grestore
2272 } def
2273
2274 %% syntaxe : {X} {Y} courbeparam
2275 /courbeparam {
2276    dup isstring
2277       {
2278          tmin tmax
2279          5 -1 roll
2280          5 -1 roll
2281          5 -1 roll
2282       }
2283       {
2284          tmin tmax
2285          4 -1 roll
2286          4 -1 roll
2287       }
2288    ifelse
2289    Courbeparam
2290 } def
2291
2292 %% syntaxe : tmin tmax {X} {Y} Courbeparam*
2293 /Courbeparam* {
2294 1 dict begin
2295    /startest {true} def
2296    Courbeparam
2297 end
2298 } def
2299
2300 %% syntaxe : {X} {Y} courbeparam*
2301 /courbeparam* {
2302 1 dict begin
2303    /startest {true} def
2304    courbeparam
2305 end
2306 } def
2307
2308 %%%%% ### courbe ###
2309 %% syntaxe : {f} courbe
2310 /courbe {
2311    dup isstring   %% y a-t-il une option de fin de ligne ?
2312       {
2313          xmin xmax
2314          {}
2315          5 -1 roll
2316          5 -1 roll
2317       }
2318       {
2319          xmin xmax
2320          {}
2321          4 -1 roll
2322       }
2323    ifelse
2324    Courbeparam
2325 } def
2326
2327 %% syntaxe : mini maxi {f} Courbe
2328 /Courbe {
2329    dup isstring {
2330       {}
2331       3 -1 roll
2332       3 -1 roll
2333    } {
2334       {}
2335       2 -1 roll
2336    } ifelse
2337    Courbeparam
2338 } def
2339
2340 %% syntaxe : {f} courbe_
2341 /courbe_ {
2342    xmin xmax
2343    {}
2344    4 -1 roll
2345    Courbeparam_
2346 } def
2347
2348 %% syntaxe : mini maxi {f} Courbe_
2349 /Courbe_ {
2350    {}
2351    2 -1 roll
2352    Courbeparam_
2353 } def
2354
2355 %% syntaxe : mini maxi {f} Courbe*
2356 /Courbe* {
2357 1 dict begin
2358    /startest {true} def
2359    Courbe
2360 end
2361 } def
2362
2363 %% syntaxe : {f} courbe*
2364 /courbe* {
2365 1 dict begin
2366    /startest {true} def
2367    courbe
2368 end
2369 } def
2370
2371 %%%%% ### courbeR2 ###
2372 %% syntaxe : tmin tmax C@urbeR2_
2373  /C@urbeR2_ {
2374 6 dict begin
2375    /tmax@ exch def
2376    /tmin@ exch def
2377    /t tmin@ def
2378    /dt tmax@ tmin@ sub resolution 1 sub div def
2379    tmin@ courbe_dic /X get exec
2380    pstrickactionR2
2381    smoveto
2382    /t t dt add store
2383    resolution 2 sub
2384    {
2385       t courbe_dic /X get exec
2386       pstrickactionR2
2387       slineto
2388       /t t dt add store                      %% on incremente
2389    }
2390    repeat
2391    tmax@ courbe_dic /X get exec
2392    pstrickactionR2
2393    slineto
2394 end
2395 } def
2396
2397 %% syntaxe : tmin tmax {X} CourbeR2_
2398 /CourbeR2_ {
2399    courbe_dic exch /X exch put
2400    C@urbeR2_
2401 } def
2402
2403 %% syntaxe : {X} courbeR2_
2404 /courbeR2_ {
2405    tmin tmax
2406    3 -1 roll
2407    3 -1 roll
2408    CourbeR2_
2409 } def
2410
2411 %% syntaxe : tmin tmax {X} CourbeR2
2412 /CourbeR2+ {
2413 2 dict begin
2414    /slineto {} def
2415    /smoveto {} def
2416    CourbeR2
2417 end
2418 } bind def
2419
2420 /CourbeR2 {
2421 gsave
2422 6 dict begin
2423    dup isstring
2424       {
2425          /option exch def
2426       }
2427    if
2428    courbe_dic exch /X exch put
2429    /tmax exch def
2430    /tmin exch def
2431
2432    newpath
2433       tmin tmax C@urbeR2_
2434       starfill
2435    currentlinewidth 0 eq {} { Stroke } ifelse
2436
2437 end
2438 grestore
2439 } def
2440
2441 %% syntaxe : {X} courbeR2
2442 /courbeR2 {
2443    tmin tmax
2444    3 -1 roll
2445    CourbeR2
2446 } def
2447
2448 %% syntaxe : tmin tmax {X} CourbeR2*
2449 /CourbeR2* {
2450 1 dict begin
2451    /startest {true} def
2452    CourbeR2
2453 end
2454 } def
2455
2456 %% syntaxe : {X} {Y} courbeR2*
2457 /courbeR2* {
2458 1 dict begin
2459    /startest {true} def
2460    courbeR2
2461 end
2462 } def
2463
2464 %%%%% ### courbeR3 ###
2465 %% syntaxe : t1 t2 {f} (option) CourbeR3
2466 /CourbeR3 {
2467 2 dict begin
2468    dup isstring {
2469       /option exch def
2470    } if
2471    /lafonction exch def
2472    {lafonction 3dto2d}
2473    currentdict /option known
2474       {option}
2475    if
2476   CourbeR2
2477 end
2478 } def
2479
2480 %% syntaxe : {f} (option) CourbeR3
2481 /courbeR3 {
2482    tmin tmax 3 -1 roll CourbeR3
2483 } def
2484
2485 %%%%% ### cercle ###
2486 %% syntaxe : x0 y0 r cercle
2487 /cercle {
2488 3 dict begin
2489    /r@y@n exch def
2490    /y@ exch def
2491    /x@ exch def
2492    0 360 {cos r@y@n mul x@ add} {sin r@y@n mul y@ add} Courbeparam
2493 end
2494 } def
2495
2496 %% syntaxe : x0 y0 r cercle_
2497 /cercle_ {
2498 3 dict begin
2499    /r@y@n exch def
2500    /y@ exch def
2501    /x@ exch def
2502    x@ r@y@n add y@ smoveto
2503    0 360 {cos r@y@n mul x@ add} {sin r@y@n mul y@ add} Courbeparam_
2504 end
2505 } def
2506
2507 %% syntaxe : x0 y0 r cercle-_
2508 /cercle-_ {
2509 3 dict begin
2510    /r@y@n exch def
2511    /y@ exch def
2512    /x@ exch def
2513    x@ r@y@n add y@ smoveto
2514    360 0 {cos r@y@n mul x@ add} {sin r@y@n mul y@ add} Courbeparam_
2515 end
2516 } def
2517
2518 %% syntaxe : x0 y0 r cercle*
2519 /cercle* {
2520 1 dict begin
2521    /startest true def
2522    cercle
2523 end
2524 } def
2525
2526 %% syntaxe : alpha beta x0 y0 r Cercle
2527 /Cercle {
2528 4 dict begin
2529    dup isstring
2530       {/option exch def}
2531    if
2532    /r@y@n exch def
2533    /y@ exch def
2534    /x@ exch def
2535    {cos r@y@n mul x@ add} {sin r@y@n mul y@ add}
2536    currentdict /option known
2537       {option}
2538    if
2539    Courbeparam
2540 end
2541 } def
2542
2543 %% syntaxe : alpha beta x0 y0 r Cercle_
2544 /Cercle_ {
2545 3 dict begin
2546    /r@y@n exch def
2547    /y@ exch def
2548    /x@ exch def
2549    {cos r@y@n mul x@ add} {sin r@y@n mul y@ add} Courbeparam_
2550 end
2551 } def
2552
2553 %% syntaxe : alpha beta x0 y0 r Cercle
2554 /Cercle* {
2555 1 dict begin
2556    /startest {true} def
2557    Cercle
2558 end
2559 } def
2560
2561 %%%%% ### fin insertion ###
2562
2563 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2564 %%%%      fonctions et constantes mathematiques         %%%%
2565 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2566
2567 %%%%% ### math ###
2568 %%%%%%%%%%% constantes mathematiques %%%%%%%%%%%%%%
2569
2570 /pi 3.14159 def
2571 /e 2.71828 def
2572
2573 %%%%%%%%%%% fonctions mathematiques %%%%%%%%%%%%%%%
2574
2575 /rd {180 pi div mul} def        %% transforme des rd en degres
2576 /deg {pi mul 180 div} def       %% transforme des degres en rd
2577 /log {ln 10 ln div} def
2578 /Exp {e exch exp} def
2579 /Cos {rd cos} def
2580 /Sin {rd sin} def
2581 /tan {dup sin exch cos div} def
2582 /cotan {dup cos exch sin div} def
2583 /Tan {dup Sin exch Cos div} def
2584 /Cotan {dup Cos exch Sin div} def
2585 /coTan {Cotan} def
2586 /arctan {
2587 dup 0 ge
2588    {1 atan}
2589    {neg 1 atan neg}
2590 ifelse
2591 } def
2592 /Arctan {arctan deg} def
2593 /arccos {
2594    dup
2595    dup mul neg 1 add sqrt
2596    exch
2597    atan
2598 } def
2599 /Arccos {arccos deg} def
2600 /arcsin {
2601    dup 1 eq {
2602       90
2603    } {
2604       dup
2605       dup mul neg 1 add sqrt
2606       atan
2607       dup 90 lt
2608          {}
2609          {360 sub}
2610       ifelse
2611    } ifelse
2612 } def
2613 /Arcsin {arcsin deg} def
2614 /cosh {dup Exp exch neg Exp add 2 div} def
2615 /sinh {dup Exp exch neg Exp sub 2 div} def
2616 /tanh {dup sinh exch cosh div} def
2617 /cotanh {dup cosh exch sinh div} def
2618 /argcosh {dup dup mul 1 sub sqrt add ln} def
2619 /argsinh {dup dup mul 1 add sqrt add ln} def
2620 /argtanh {
2621    setxvar
2622    x 1 add
2623    1 x sub
2624    div
2625    ln
2626    2 div
2627 } def
2628 /factorielle {
2629       dup 0 eq
2630          {pop 1}
2631          {dup 1 sub factorielle mul}
2632       ifelse
2633 } def
2634 /Gauss {
2635 3 dict begin
2636    /sigma exch def
2637    /m exch def
2638    /x exch def
2639    x m sub dup mul sigma dup mul 2 mul div neg Exp
2640    2 pi mul sigma dup mul mul sqrt div
2641 end
2642 } def
2643 %% syntaxe : a n modulo
2644 /modulo {
2645 2 dict begin
2646    /n exch def
2647    /a exch def
2648    {
2649       a 0 lt {
2650          /a a n add store
2651       } {
2652          exit
2653       } ifelse
2654    } loop
2655    a n mod
2656 end
2657 } def
2658
2659 %%%%% ### max ###
2660 /max {
2661    2 copy
2662    lt {exch} if
2663    pop
2664 } def
2665
2666 %%%%% ### min ###
2667 /min {
2668 2 dict begin
2669    dup isarray {
2670       duparray /table exch def pop
2671       table 0 get
2672       1 1 table length 1 sub {
2673          /i exch def
2674          table i get
2675          min
2676       } for
2677    } {
2678       2 copy
2679       gt {exch} if
2680       pop
2681    } ifelse
2682 end
2683 } def
2684
2685 %%%%% ### setcolor ###
2686 %% syntaxe : tableau setcolor
2687 /setcolor {
2688    dup length 4 eq
2689       {aload pop setcmykcolor}
2690       {aload pop setrgbcolor}
2691    ifelse
2692 } def
2693
2694 %%%%% ### in ###
2695 %% cherche si un elt donne appartient au tableau donne
2696 %% rque : utilise 3 variables locales
2697 %% syntaxe : elt array in --> index boolean
2698 /in {
2699 3 dict begin
2700    /liste exch def
2701    /elt exch def
2702    /i 0 def
2703    false                        %% la reponse a priori
2704    liste length {
2705       liste i get elt eq {
2706          pop                    %% en enleve la reponse
2707          i true                 %% pour mettre la bonne
2708          exit
2709       } if
2710       /i i 1 add store
2711    } repeat
2712 end
2713 } def
2714
2715 %% cherche si un elt donne appartient au tableau donne
2716 %% syntaxe : elt array in --> boolean
2717 /In {
2718 3 dict begin
2719    /liste exch def
2720    /elt exch def
2721    /i 0 def
2722    false                        %% la reponse a priori
2723    liste length {
2724       liste i get elt eq {
2725          pop                    %% en enleve la reponse
2726          true                 %% pour mettre la bonne
2727          exit
2728       } if
2729       /i i 1 add store
2730    } repeat
2731 end
2732 } def
2733
2734 %%%%% ### starfill ###
2735 %% la procedure pour les objets "star"
2736 %% si c est "star" on fait le fillstyle, sinon non
2737 /starfill {
2738    startest {
2739       gsave
2740          clip
2741          fillstyle
2742       grestore
2743       /startest false def
2744    } if
2745 } def
2746
2747 %%%%% ### addv ###
2748 %% syntaxe : u v addv --> u+v
2749 /addv {         %% xA yA xB yB
2750    3 1 roll     %% xA yB yA xB
2751    4 1 roll     %% xB xA yB yA
2752    add 3 1 roll %% yB+yA xB xA
2753    add exch
2754 } def
2755
2756 %%%%% ### continu ###
2757 /continu {
2758    [] 0 setdash
2759 } def
2760
2761 %%%%% ### trigospherique ###
2762 %% passage spherique --> cartesiennes
2763 %% les formules de passage ont été récupérées ici :
2764 %%    http://fr.wikipedia.org/wiki/Coordonn%C3%A9es_polaires
2765 %% syntaxe : r theta phi rtp2xyz -> x y z
2766 /rtp2xyz {
2767 6 dict begin
2768    /phi exch def
2769    /theta exch def
2770    /r exch def
2771    /x phi cos theta cos mul r mul def
2772    /y phi cos theta sin mul r mul def
2773    /z phi sin r mul def
2774    x y z
2775 end
2776 } def
2777
2778 %% trace d'un arc sur une sphere de centre O
2779 %% syntaxe : r theta1 phi1 r theta2 phi2 arcspherique
2780 /arcspherique {
2781 9 dict begin
2782    dup isstring {
2783       /option exch def
2784    } if
2785    /phi2 exch def
2786    /theta2 exch def
2787    pop
2788    /phi1 exch def
2789    /theta1 exch def
2790    /r exch def
2791    /n 12 def
2792
2793    1 theta1 phi1 rtp2xyz /u defpoint3d
2794    1 theta2 phi2 rtp2xyz /v defpoint3d
2795    u v vectprod3d u vectprod3d dupp3d norme3d 1 exch div mulv3d /w defpoint3d
2796
2797    /sinalpha u v vectprod3d norme3d def
2798    /cosalpha u v scalprod3d def
2799    /alpha sinalpha cosalpha atan def
2800    /n 12 def
2801    /pas alpha n div def
2802
2803    gsave
2804       /t pas neg def
2805       [
2806          n 1 add {
2807             /t  t pas add store
2808             u t cos r mul mulv3d
2809             w t sin r mul mulv3d
2810             addv3d
2811          } repeat
2812       ]
2813       currentdict /option known {
2814          option
2815       } if
2816       ligne3d
2817    grestore
2818 end
2819 } def
2820
2821 %% trace d'un arc sur une sphere de centre O
2822 %% syntaxe : r theta1 phi1 r theta2 phi2 arcspherique
2823 /arcspherique_ {
2824 8 dict begin
2825    /phi2 exch def
2826    /theta2 exch def
2827    pop
2828    /phi1 exch def
2829    /theta1 exch def
2830    /r exch def
2831    /n 12 def
2832
2833    1 theta1 phi1 rtp2xyz /u defpoint3d
2834    1 theta2 phi2 rtp2xyz /v defpoint3d
2835    u v vectprod3d u vectprod3d dupp3d norme3d 1 exch div mulv3d /w defpoint3d
2836
2837    /sinalpha u v vectprod3d norme3d def
2838    /cosalpha u v scalprod3d def
2839    /alpha sinalpha cosalpha atan def
2840    /n 12 def
2841    /pas alpha n div def
2842
2843    /t pas neg def
2844    [
2845       n 1 add {
2846          /t  t pas add store
2847          u t cos r mul mulv3d
2848          w t sin r mul mulv3d
2849          addv3d
2850       } repeat
2851    ] ligne3d_
2852 end
2853 } def
2854
2855 %% trace d'une geodesique sur une sphere de centre O
2856 %% syntaxe : r theta1 phi1 r theta2 phi2 geodesique_sphere
2857 /geodesique_sphere {
2858 13 dict begin
2859    /phi2 exch def
2860    /theta2 exch def
2861    pop
2862    /phi1 exch def
2863    /theta1 exch def
2864    /r exch def
2865    /n 360 def
2866
2867    1 theta1 phi1 rtp2xyz /u defpoint3d
2868    1 theta2 phi2 rtp2xyz /v defpoint3d
2869    u v vectprod3d u vectprod3d dupp3d norme3d 1 exch div mulv3d /w defpoint3d
2870
2871    /sinalpha u v vectprod3d norme3d def
2872    /cosalpha u v scalprod3d def
2873    /alpha sinalpha cosalpha atan def
2874    /pas 360 n div def
2875
2876    gsave
2877       /t pas neg def
2878       [
2879          n 1 add {
2880             /t  t pas add store
2881             u t cos r mul mulv3d
2882             w t sin r mul mulv3d
2883             addv3d
2884          } repeat
2885       ] ligne3d
2886    grestore
2887 end
2888 } def
2889
2890
2891 %% syntaxe : A B C trianglespherique --> trace le rtiangle ABC
2892 %% (coordonnees spheriques)
2893 /trianglespherique* {
2894 1 dict begin
2895    /startest {true} def
2896    trianglespherique
2897 end
2898 } def
2899
2900 /trianglespherique {
2901 10 dict begin
2902    /C defpoint3d
2903    /B defpoint3d
2904    /A defpoint3d
2905    gsave
2906    newpath
2907       A rtp2xyz 3dto2d smoveto
2908       A B arcspherique_
2909       B C arcspherique_
2910       C A arcspherique_
2911    closepath
2912    starfill
2913    currentlinewidth 0 eq {} { Stroke } ifelse
2914    grestore
2915 end
2916 } def
2917
2918 %%%%% ### fin insertion ###
2919
2920 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2921 %%%%         operations sur les tableaux                %%%%
2922 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2923
2924 %%%%% ### duparray ###
2925 /duparray {
2926 1 dict begin
2927    /table exch def
2928    table
2929    [ table aload pop ]
2930 end
2931 } def
2932
2933 %%%%% ### append ###
2934 %% syntaxe : string1 string2 append --> concatene les 2 chaines ou fusionne 2 tableaux
2935 /append {
2936 3 dict begin
2937    dup isarray {
2938       /tab2 exch def
2939       /tab1 exch def
2940       [ tab1 aload pop tab2 aload pop ]
2941    } {
2942       /str2 exch def
2943       /str1 exch def
2944       /result str1 length str2 length add string def
2945       str1 result copy pop
2946       result str1 length str2 putinterval
2947       result
2948    } ifelse
2949 end
2950 } def
2951
2952 %%%%% ### rollparray ###
2953 %% syntaxe : array n rollparray -> array
2954 %% opere une rotation de n sur les couplets du tableau array
2955 /rollparray {
2956 4 dict begin
2957    /k exch def
2958    /table exch def
2959    /n table length def
2960    k 0 eq {
2961        table
2962    } {
2963        k 0 ge {
2964           [ table aload pop 2 {n 1 roll} repeat ]
2965            k 1 sub
2966        } {
2967           [ table aload pop 2 {n -1 roll} repeat ]
2968            k 1 add
2969        } ifelse
2970        rollparray
2971    } ifelse
2972 end
2973 } def
2974
2975 %%%%% ### bubblesort ###
2976 %% syntaxe : array bubblesort --> array2 trie par ordre croissant
2977 %% code de Bill Casselman
2978 %% http://www.math.ubc.ca/people/faculty/cass/graphics/text/www/
2979 /bubblesort {
2980 4 dict begin
2981    /a exch def
2982    /n a length 1 sub def
2983    n 0 gt {
2984       % at this point only the n+1 items in the bottom of a remain to
2985       % the sorted largest item in that blocks is to be moved up into
2986       % position n
2987       n {
2988          0 1 n 1 sub {
2989             /i exch def
2990             a i get a i 1 add get gt {
2991                % if a[i] > a[i+1] swap a[i] and a[i+1]
2992                a i 1 add
2993                a i get
2994                a i a i 1 add get
2995                % set new a[i] = old a[i+1]
2996                put
2997                % set new a[i+1] = old a[i]
2998                put
2999             } if
3000          } for
3001          /n n 1 sub def
3002       } repeat
3003    } if
3004    a
3005 end
3006 } def
3007
3008 %% syntaxe : array1 doublebubblesort --> array2 array3, array3 est
3009 %% trie par ordre croissant et array2 correspond a la position des
3010 %% indices de depart, ie si array1 = [3 2 4 1], alors array2 = [3 1 0 2]
3011 %% code de Bill Casselman, modifie par jpv, 15/08/2006
3012 %% http://www.math.ubc.ca/people/faculty/cass/graphics/text/www/
3013 /doublebubblesort {
3014 5 dict begin
3015    /table exch def
3016    /n table length 1 sub def
3017    /indices [ 0 1 n {} for ] def
3018    n 0 gt {
3019       % at this point only the n+1 items in the bottom of a remain to
3020       % the sorted largest item in that blocks is to be moved up into
3021       % position n
3022       n {
3023          0 1 n 1 sub {
3024             /i exch def
3025             table i get table i 1 add get gt {
3026                % if a[i] > a[i+1] swap a[i] and a[i+1]
3027                table i 1 add
3028                table i get
3029                table i table i 1 add get
3030                % set new a[i] = old a[i+1]
3031                put
3032                % set new a[i+1] = old a[i]
3033                put
3034
3035                indices i 1 add
3036                indices i get
3037                indices i indices i 1 add get
3038                % set new a[i] = old a[i+1]
3039                put
3040                % set new a[i+1] = old a[i]
3041                put
3042             } if
3043          } for
3044          /n n 1 sub def
3045       } repeat
3046    } if
3047    indices table
3048 end
3049 } def
3050
3051 %%%%% ### quicksort ###
3052 %% src : http://www.math.ubc.ca/~cass/graphics/text/www/code/sort.inc
3053 %% code de Bill Casselman, modifie par jpv, 18/10/2007
3054
3055 /qsortdict 8 dict def
3056
3057 qsortdict begin
3058
3059 % args: /comp a L R x
3060 % effect: effects a partition into two pieces [L j] [i R]
3061 %     leaves i j on stack
3062
3063 /partition { 8 dict begin
3064 /x exch def
3065 /j exch def
3066 /i exch def
3067 /a exch def
3068 load /comp exch def
3069 {
3070   {
3071     a i get x comp exec not {
3072       exit
3073     } if
3074     /i i 1 add def
3075   } loop
3076   {
3077     x a j get comp exec not {
3078       exit
3079     } if
3080     /j j 1 sub def
3081   } loop
3082
3083   i j le {
3084     % swap a[i] a[j]
3085     a j a i get
3086     a i a j get
3087     put put
3088     indices j indices i get
3089     indices i indices j get
3090     put put
3091     /i i 1 add def
3092     /j j 1 sub def
3093   } if
3094   i j gt {
3095     exit
3096   } if
3097 } loop
3098 i j
3099 end } def
3100
3101 % args: /comp a L R
3102 % effect: sorts a[L .. R] according to comp
3103
3104 /subsort {
3105 % /c a L R
3106 [ 3 1 roll ] 3 copy
3107 % /c a [L R] /c a [L R]
3108 aload aload pop
3109 % /c a [L R] /c a L R L R
3110 add 2 idiv
3111 % /c a [L R] /c a L R (L+R)/2
3112 3 index exch get
3113 % /c a [L R] /c a L R x
3114 partition
3115 % /c a [L R] i j
3116 % if j > L subsort(a, L, j)
3117 dup
3118 % /c a [L R] i j j
3119 3 index 0 get gt {
3120   % /c a [L R] i j
3121   5 copy
3122   % /c a [L R] i j /c a [L R] i j
3123   exch pop
3124   % /c a [L R] i j /c a [L R] j
3125   exch 0 get exch
3126   % ... /c a L j
3127   subsort
3128 } if
3129 % /c a [L R] i j
3130 pop dup
3131 % /c a [L R] i i
3132 % if i < R subsort(a, i, R)
3133 2 index 1 get lt {
3134   % /c a [L R] i
3135   exch 1 get
3136   % /c a i R
3137   subsort
3138 }{
3139   4 { pop } repeat
3140 } ifelse
3141 } def
3142
3143 end
3144
3145 % args: /comp a
3146 % effect: sorts the array a
3147 % comp returns truth of x < y for entries in a
3148
3149 /quicksort { qsortdict begin
3150 dup length 1 gt {
3151 % /comp a
3152 dup
3153 % /comp a a
3154 length 1 sub
3155 % /comp a n-1
3156 0 exch subsort
3157 } {
3158 pop pop
3159 } ifelse
3160 end } def
3161
3162 % ----------------------------------------
3163
3164 %% fin du code de Bill Casselman
3165
3166 %% syntaxe : array1 doublebubblesort --> array2 array3, array3 est
3167 %% trie par ordre croissant et array2 correspond a la position des
3168 %% indices de depart, ie si array1 = [3 2 4 1], alors array2 = [3 1 0 2]
3169 %% code de Bill Casselman, modifie par jpv, 18/10/2007
3170 %% http://www.math.ubc.ca/people/faculty/cass/graphics/text/www/
3171 /doublequicksort {
3172 qsortdict begin
3173    /comp exch
3174    /a exch def
3175    a dup length /n exch def
3176    /indices [0 1 n 1 sub {} for ] def
3177    dup length 1 gt {
3178       % /comp a
3179       dup
3180       % /comp a a
3181       length 1 sub
3182       % /comp a n-1
3183       0 exch subsort
3184    } {
3185       pop pop
3186    } ifelse
3187    indices a
3188 end
3189 } def
3190
3191 /comp {lt} def
3192
3193 %%%%% ### apply ###
3194 %% syntaxe : [x1 ... xn] (f) apply --> [f(x1) ... f(xn)]
3195 /apply {
3196 3 dict begin
3197    dup isstring
3198       {/fonction exch cvx def}
3199       {/fonction exch def}
3200    ifelse
3201    /liste exch def
3202    /@i 0 def
3203    [
3204    liste length {
3205       liste @i get fonction
3206       /@i @i 1 add store
3207    } repeat
3208    counttomark
3209    0 eq
3210       {pop}
3211       {]}
3212    ifelse
3213 end
3214 } def
3215
3216 %% syntaxe : [x1 ... xn] (f) papply
3217 /papply {
3218 3 dict begin
3219    dup isstring
3220       {/fonction exch cvx def}
3221       {/fonction exch def}
3222    ifelse
3223    /liste exch def
3224    /@i 0 def
3225    [
3226    liste length 2 idiv {
3227       liste @i get
3228       liste @i 1 add get
3229       fonction
3230       /@i @i 2 add store
3231    } repeat
3232    counttomark
3233    0 eq
3234       {pop}
3235       {]}
3236    ifelse
3237 end
3238 } def
3239
3240 %% syntaxe : [x1 ... xn] (f) capply
3241 /capply {
3242 3 dict begin
3243    dup isstring
3244       {/fonction exch cvx def}
3245       {/fonction exch def}
3246    ifelse
3247    /liste exch def
3248    /@i 0 def
3249    [
3250    liste length 3 idiv {
3251       liste @i get
3252       liste @i 1 add get
3253       liste @i 2 add get
3254       fonction
3255       /@i @i 3 add store
3256    } repeat
3257    counttomark
3258    0 eq
3259       {pop}
3260       {]}
3261    ifelse
3262 end
3263 } def
3264
3265 %%%%% ### reverse ###
3266 %% syntaxe : array reverse --> inverse l ordre des items dans
3267 %% le tableau
3268 /reverse {
3269 3 dict begin
3270    /le_tableau exch def
3271    /n le_tableau length def
3272    /i n 1 sub def
3273    [
3274       n {
3275          le_tableau i get
3276          /i i 1 sub store
3277       } repeat
3278    ]
3279 end
3280 } def
3281
3282 %% syntaxe : array_points reversep --> inverse l ordre des points dans
3283 %% le tableau
3284 /reversep {
3285 3 dict begin
3286    /le_tableau exch def
3287    /n le_tableau length 2 idiv def
3288    /i n 1 sub def
3289    [
3290       n {
3291          le_tableau i getp
3292          /i i 1 sub store
3293       } repeat
3294    ]
3295 end
3296 } def
3297
3298 %%%%% ### get ###
3299 %% syntaxe : array_points n getp --> le n-ieme point du tableau de
3300 %% points array_points
3301 /getp {
3302    2 copy
3303    2 mul get
3304    3 1 roll
3305    2 mul 1 add get
3306 } def
3307
3308 %%%%% ### fin insertion ###
3309
3310 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3311 %%%%             matrices                               %%%%
3312 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3313
3314 %%%%% ### linear ###
3315 %% syntaxe : M i j any --> depose any dans M en a_ij
3316 /put_ij {
3317 5 dict begin
3318    /a exch def
3319    /j exch def
3320    /i exch def
3321    /M exch def
3322    /L M i get_Li def
3323    L j a put
3324    M i L put_Li
3325 end
3326 } def
3327
3328 %% syntaxe : M i j get_ij --> le coeff c_ij
3329 /get_ij {
3330    3 1 roll   %% j M i
3331    get_Li     %% j L_i
3332    exch get
3333 } def
3334
3335 %% syntaxe : M i L put_Li --> remplace dans M la ligne Li par L
3336 /put_Li {
3337    put
3338 } def
3339
3340 %% syntaxe : M i get_Li --> la ligne Li de M
3341 /get_Li {
3342    get
3343 } def
3344
3345 %%%%% ### fin insertion ###
3346
3347 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3348 %%%%          geometrie 3d (calculs)                    %%%%
3349 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3350
3351 %%%%% ### p3dtoplane ###
3352 %% syntaxe : x y z P p3dtoplane --> X Y
3353 /p3dtoplane {
3354 5 dict begin
3355    /leplan exch def
3356    /M defpoint3d
3357    leplan plangetbase 0 getp3d /U defpoint3d
3358    leplan plangetbase 1 getp3d /V defpoint3d
3359    leplan plangetorigine /I defpoint3d
3360    I M vecteur3d U scalprod3d
3361    I M vecteur3d V scalprod3d
3362 end
3363 } def
3364
3365 %%%%% ### pplaneto3d ###
3366 %% syntaxe : x y P pplaneto3d --> X Y Z
3367 /pplaneto3d {
3368 6 dict begin
3369    /leplan exch def
3370    /y exch def
3371    /x exch def
3372    leplan plangetbase 0 getp3d /U defpoint3d
3373    leplan plangetbase 1 getp3d /V defpoint3d
3374    leplan plangetorigine /I defpoint3d
3375    U x mulv3d
3376    V y mulv3d addv3d
3377    I addv3d
3378 end
3379 } def
3380
3381 %%%%% ### orthoprojplane3d ###
3382 %% Projection orthogonale d'un point 3d sur un plan
3383 %% Mx My Mz (=le point a projeter)
3384 %% Ax Ay Az (=un point du plan)
3385 %% Vx Vy Vz (un vecteur normal au plan)
3386 /orthoprojplane3d {
3387 4 dict begin
3388    dup isplan {
3389       /monplan exch def
3390       monplan plangetorigine
3391       monplan plangetbase aload pop vectprod3d
3392    } if
3393    /V defpoint3d
3394    /A defpoint3d
3395    /M defpoint3d
3396    /VN {V unitaire3d} def
3397    VN M A vecteur3d VN scalprod3d mulv3d
3398    M addv3d
3399 end
3400 } def
3401
3402 %%%%% ### sortp3d ###
3403 /sortp3d {
3404 6 dict begin
3405    /M1 defpoint3d
3406    /M0 defpoint3d
3407    M1
3408    /z1 exch def
3409    /y1 exch def
3410    /x1 exch def
3411    M0
3412    /z0 exch def
3413    /y0 exch def
3414    /x0 exch def
3415    x0 x1 lt {
3416       M0 M1
3417    } {
3418       x0 x1 gt {
3419          M1 M0
3420       } {
3421          y0 y1 lt {
3422             M0 M1
3423          } {
3424             y0 y1 gt {
3425                M1 M0
3426             } {
3427                z0 z1 lt {
3428                   M0 M1
3429                } {
3430                   M1 M0
3431                } ifelse
3432             } ifelse
3433          } ifelse
3434       } ifelse
3435    } ifelse
3436 end
3437 } def
3438
3439 %%%%% ### dupp3d ###
3440 %% duplique le vecteur 3d
3441 /dupp3d { %% x y z
3442         3 copy
3443 } def
3444 /dupv3d {dupp3d} def
3445
3446 %%%%% ### angle3d ###
3447 %% syntaxe : vect1 vect2 angle3d
3448 /angle3d {
3449 4 dict begin
3450    normalize3d /vect2 defpoint3d
3451    normalize3d /vect1 defpoint3d
3452    /cosalpha vect1 vect2 scalprod3d def
3453    /sinalpha vect1 vect2 vectprod3d norme3d def
3454    sinalpha cosalpha atan
3455 end
3456 } def
3457
3458 %%%%% ### transformpoint3d ###
3459 %% syntaxe : x y z a11 a21 a31 a12 a22 a32 a13 a23 a33
3460 %%    transformpoint3d -> X Y Z
3461 /transformpoint3d {
3462 12 dict begin
3463    /a33 exch def
3464    /a23 exch def
3465    /a13 exch def
3466    /a32 exch def
3467    /a22 exch def
3468    /a12 exch def
3469    /a31 exch def
3470    /a21 exch def
3471    /a11 exch def
3472    /z   exch def
3473    /y   exch def
3474    /x   exch def
3475    a11 x mul a12 y mul add a13 z mul add
3476    a21 x mul a22 y mul add a23 z mul add
3477    a31 x mul a32 y mul add a33 z mul add
3478 end
3479 } def
3480
3481 %%%%% ### normalize3d ###
3482 %% rend le vecteur 3d unitaire. Ne fait rien si u=0
3483 /unitaire3d { %% x y z
3484 2 dict begin
3485    /u defpoint3d
3486    /norme u norme3d def
3487    norme 0 eq {
3488       u
3489    } {
3490       u 1 norme div mulv3d
3491    } ifelse
3492 end
3493 } def
3494 /normalize3d {unitaire3d} def
3495
3496 %%%%% ### geom3d ###
3497 %% syntaxe : A k1 B k2 barycentre3d -> G, barycentre du systeme
3498 %% [(A, k1) (B, k2)]
3499 /barycentre3d {
3500 4 dict begin
3501    /k2 exch def
3502    /B defpoint3d
3503    /k1 exch def
3504    /A defpoint3d
3505    A k1 mulv3d
3506    B k2 mulv3d
3507    addv3d
3508    1 k1 k2 add div mulv3d
3509 end
3510 } def
3511
3512 %% syntaxe : array isobarycentre3d --> G
3513 /isobarycentre3d {
3514 2 dict begin
3515    /table exch def
3516    /n table length 3 idiv def
3517    table 0 getp3d
3518    1 1 n 1 sub {
3519        table exch getp3d
3520        addv3d
3521    } for
3522    1 n div mulv3d
3523 end
3524 } def
3525
3526 %% syntaxe : M A alpha hompoint3d -> le point M' tel que AM' = alpha AM
3527 /hompoint3d {
3528 3 dict begin
3529    /alpha exch def
3530    /A defpoint3d
3531    /M defpoint3d
3532    A M vecteur3d alpha mulv3d A addv3d
3533 end
3534 } def
3535
3536 %% syntaxe : M A sympoint3d -> le point M' tel que AM' = -AM
3537 /sympoint3d {
3538 2 dict begin
3539    /A defpoint3d
3540    /M defpoint3d
3541    A M vecteur3d -1 mulv3d A addv3d
3542 end
3543 } def
3544
3545 %% syntaxe : A u translatepoint3d --> B image de A par la translation de vecteur u
3546 /translatepoint3d {
3547    addv3d
3548 } def
3549
3550 /scaleOpoint3d {
3551 6 dict begin
3552    /k3 exch def
3553    /k2 exch def
3554    /k1 exch def
3555    /z exch def
3556    /y exch def
3557    /x exch def
3558    k1 x mul
3559    k2 y mul
3560    k3 z mul
3561 end
3562 } def
3563
3564 % syntaxe : M alpha_x alpha_y alpha_z rotateOpoint3d --> M'
3565 /rotateOpoint3d {
3566 21 dict begin
3567    /RotZ exch def
3568    /RotY exch def
3569    /RotX exch def
3570    /Zpoint exch def
3571    /Ypoint exch def
3572    /Xpoint exch def
3573    /c1 {RotX cos} bind def
3574    /c2 {RotY cos} bind def
3575    /c3 {RotZ cos} bind def
3576    /s1 {RotX sin} bind def
3577    /s2 {RotY sin} bind def
3578    /s3 {RotZ sin} bind def
3579    /M11 {c2 c3 mul} bind def
3580    /M12 {c3 s1 mul s2 mul c1 s3 mul sub} bind def
3581    /M13 {c1 c3 mul s2 mul s1 s3 mul add} bind def
3582    /M21 {c2 s3 mul} bind def
3583    /M22 {s1 s2 mul s3 mul c1 c3 mul add} bind def
3584    /M23 {s3 s2 mul c1 mul c3 s1 mul sub} bind def
3585    /M31 {s2 neg} bind def
3586    /M32 {s1 c2 mul} bind def
3587    /M33 {c1 c2 mul} bind def
3588    M11 Xpoint mul M12 Ypoint mul add M13 Zpoint mul add
3589    M21 Xpoint mul M22 Ypoint mul add M23 Zpoint mul add
3590    M31 Xpoint mul M32 Ypoint mul add M33 Zpoint mul add
3591 end
3592 } def
3593
3594 %%%%% ### symplan3d ###
3595 %% syntaxe : M eqplan/plantype symplan3d --> M'
3596 %% ou M' symetrique de M par rapport au plan P defini par eqplan/plantype
3597 /symplan3d {
3598 13 dict begin
3599    dup isplan {
3600       plan2eq /args exch def
3601    } {
3602       /args exch def
3603    } ifelse
3604    /z exch def
3605    /y exch def
3606    /x exch def
3607    args aload pop
3608    /d1 exch def
3609    /c1 exch def
3610    /b1 exch def
3611    /a1 exch def
3612    /n_U a1 dup mul b1 dup mul add c1 dup mul add sqrt def
3613    /a a1 n_U div def
3614    /b b1 n_U div def
3615    /c c1 n_U div def
3616    /d d1 n_U div def
3617    /u a x mul b y mul add c z mul add d add def
3618    x 2 a mul u mul sub
3619    y 2 b mul u mul sub
3620    z 2 c mul u mul sub
3621 end
3622 } def
3623
3624 %%%%% ### vecteur3d ###
3625 %% creation du vecteur AB a partir de A et B
3626 /vecteur3d { %% xA yA zA xB yB zB
3627 6 dict begin
3628    /zB exch def
3629    /yB exch def
3630    /xB exch def
3631    /zA exch def
3632    /yA exch def
3633    /xA exch def
3634    xB xA sub
3635    yB yA sub
3636    zB zA sub
3637 end
3638 }def
3639
3640 %%%%% ### vectprod3d ###
3641 %% produit vectoriel de deux vecteurs 3d
3642 /vectprod3d { %% x1 y1 z1 x2 y2 z2
3643 6 dict begin
3644    /zp exch def
3645    /yp exch def
3646    /xp exch def
3647    /z exch def
3648    /y exch def
3649    /x exch def
3650    y zp mul z yp mul sub
3651    z xp mul x zp mul sub
3652    x yp mul y xp mul sub
3653 end
3654 } def
3655
3656 %%%%% ### scalprod3d ###
3657 %% produit scalaire de deux vecteurs 3d
3658 /scalprod3d { %% x1 y1 z1 x2 y2 z2
3659 6 dict begin
3660    /zp exch def
3661    /yp exch def
3662    /xp exch def
3663    /z exch def
3664    /y exch def
3665    /x exch def
3666    x xp mul y yp mul add z zp mul add
3667 end
3668 } def
3669
3670 %%%%% ### papply3d ###
3671 %% syntaxe : [A1 ... An] (f) papply3d --> [f(A1) ... f(An)]
3672 /papply3d {
3673 3 dict begin
3674    /fonction exch def
3675    /liste exch def
3676    /i 0 def
3677    [
3678    liste length 3 idiv {
3679       liste i get
3680       liste i 1 add get
3681       liste i 2 add get
3682       fonction
3683       /i i 3 add store
3684    } repeat
3685    counttomark
3686    0 eq
3687       {pop}
3688       {]}
3689    ifelse
3690 end
3691 } def
3692
3693 %%%%% ### defpoint3d ###
3694 %% creation du point A a partir de xA yA yB et du nom /A
3695 /defpoint3d { %% xA yA zA /nom
3696 1 dict begin
3697    /memo exch def
3698    [ 4 1 roll ] cvx memo exch
3699 end def
3700 }def
3701
3702 %%%%% ### distance3d ###
3703 /distance3d { %% A B
3704    vecteur3d norme3d
3705 } def
3706
3707 %%%%% ### get3d ###
3708 /getp3d { %% [tableau de points 3d] i --> donne le ieme point du tableau
3709    2 copy 2 copy
3710    3 mul get
3711    5 1 roll
3712    3 mul 1 add get
3713    3 1 roll
3714    3 mul 2 add get
3715 } def
3716
3717 %%%%% ### norme3d ###
3718 %% norme d un vecteur 3d
3719 /norme3d { %% x y z
3720 3 dict begin
3721    /z exch def
3722    /y exch def
3723    /x exch def
3724    x dup mul y dup mul add z dup mul add sqrt
3725 end
3726 } def
3727
3728 %%%%% ### mulv3d ###
3729 %% (scalaire)*(vecteur 3d) Attention : dans l autre sens !
3730 /mulv3d { %% x y z lambda
3731 4 dict begin
3732    /lambda exch def
3733    /z exch def
3734    /y exch def
3735    /x exch def
3736    x lambda mul
3737    y lambda mul
3738    z lambda mul
3739 end
3740 } def
3741
3742 %%%%% ### addv3d ###
3743 %% addition de deux vecteurs 3d
3744 /addv3d { %% x1 y1 z1 x2 y2 z2
3745 6 dict begin
3746    /zp exch def
3747    /yp exch def
3748    /xp exch def
3749    /z exch def
3750    /y exch def
3751    /x exch def
3752    x xp add
3753    y yp add
3754    z zp add
3755 end
3756 } def
3757
3758 %%%%% ### milieu3d ###
3759 /milieu3d { %% A B --> I le milieu de [AB]
3760    addv3d 0.5 mulv3d
3761 } def
3762
3763 %%%%% ### exch ###
3764 /exchp {
3765    4 -1 roll
3766    4 -1 roll
3767 } def
3768 /exchc {
3769    6 -1 roll
3770    6 -1 roll
3771    6 -1 roll
3772 } def
3773 /exchd {
3774    4 {8 -1 roll} repeat
3775 } def
3776 /exchp3d {
3777    6 -1 roll
3778    6 -1 roll
3779    6 -1 roll
3780 } def
3781
3782 %%%%% ### ABpoint3d ###
3783 %% syntaxe : A B k ABpoint3d --> M
3784 %% M tel que vect(AM) = k vect (AB)
3785 /ABpoint3d {
3786 3 dict begin
3787    /k exch def
3788    /B defpoint3d
3789    /A defpoint3d
3790    A B vecteur3d
3791    k mulv3d
3792    A addv3d
3793 end
3794 } def
3795
3796 %%%%% ### angle3doriente ###
3797 %% syntaxe : vect1 vect2 vect3 angle3d
3798 %% vect3 est la normale au plan (vect1, vect2)
3799 /angle3doriente {
3800 4 dict begin
3801    normalize3d /vect3 defpoint3d
3802    normalize3d /vect2 defpoint3d
3803    normalize3d /vect1 defpoint3d
3804    /cosalpha vect1 vect2 scalprod3d def
3805    /sinalpha vect1 vect2 vectprod3d vect3 scalprod3d def
3806    sinalpha cosalpha atan
3807 end
3808 } def
3809
3810 %%%%% ### points3dalignes ###
3811 %% syntaxe : A B C points3dalignes -> bool
3812 /points3dalignes {
3813 3 dict begin
3814    /C defpoint3d
3815    /B defpoint3d
3816    /A defpoint3d
3817    A B vecteur3d /u defpoint3d
3818    A C vecteur3d /v defpoint3d
3819    u v vectprod3d norme3d 1E-7 lt
3820 end
3821 } def
3822
3823 %% syntaxe : M A B point3dsursegment --> true si M in [AB], false sinon
3824 /point3dsursegment {
3825 3 dict begin
3826    /B defpoint3d
3827    /A defpoint3d
3828    /M defpoint3d
3829    M A B points3dalignes {
3830       M A vecteur3d
3831       M B vecteur3d
3832       scalprod3d 0 lt {
3833          true
3834       } {
3835          false
3836       } ifelse
3837    } {
3838       false
3839    } ifelse
3840 end
3841 } def
3842
3843 %%%%% ### fin insertion ###
3844
3845 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3846 %%%%          geometrie 3d (dessins)                    %%%%
3847 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3848
3849 %%%%% ### point3d ###
3850 /point3d { %% A
3851    3dto2d point
3852 } def
3853
3854 /points3d { %% tableau de points3d
3855    tab3dto2d points
3856 } def
3857
3858 %%%%% ### ligne3d ###
3859 %% [tableau de points3d] option --> trace la ligne brisee
3860 /ligne3d {
3861 1 dict begin
3862    dup isstring
3863       {/option exch def}
3864    if
3865    tab3dto2d
3866    currentdict /option known
3867       {option}
3868    if
3869    ligne
3870 end
3871 } def
3872
3873 %% [tableau de points3d] option --> trace la ligne brisee
3874 /ligne3d_ {
3875 1 dict begin
3876    dup isstring
3877       {/option exch def}
3878    if
3879    tab3dto2d
3880    currentdict /option known
3881       {option}
3882    if
3883    ligne_
3884 end
3885 } def
3886
3887 %%%%% ### tab3dto2d ###
3888 %% transforme un tableau de points 3d en tableau de points 2d
3889 /tab3dto2d {
3890 2 dict begin
3891    /T exch def
3892    /n T length def
3893    [ T aload pop
3894    n 1 sub -1 n 3 idiv 2 mul
3895    { 1 dict begin
3896    /i exch def
3897    3dto2d i 2 roll
3898    end } for ]
3899 end
3900 } def
3901
3902 %%%%% ### polygone3d ###
3903 /polygone3d { %% tableau de points3d
3904    tab3dto2d polygone
3905 } def
3906
3907 /polygone3d* { %% tableau de points3d
3908    tab3dto2d polygone*
3909 } def
3910
3911 %%%%% ### fin insertion ###
3912
3913 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3914 %%%%                 gestion du texte                   %%%%
3915 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3916
3917 %%%%% ### marks ###
3918 /xmkstep 1 def          % les marques sur Ox
3919 /xmarkstyle {dctext} def
3920 /ymarkstyle {(-1 0) bltext} def
3921 /setxmkstep {
3922    /xmkstep exch def
3923 } def
3924 /xmark {
3925    dup xtick
3926    /Courier findfont .8 fontsize mul scalefont setfont
3927    dup dup truncate eq {
3928       cvi dup chaine cvs exch
3929    } {
3930       dup chaine cvs exch
3931    } ifelse
3932    Oy xmarkstyle
3933 } def
3934 /xmarks {
3935 2 dict begin
3936    /n xmax xmax xmin sub 1000 div sub xmkstep div truncate cvi
3937       xmkstep mul def                   % mark max
3938    /i xmin xmkstep div truncate cvi
3939       xmkstep mul def                   % la 1ere
3940    i xmin lt {/i i xmkstep add store} if
3941    {
3942       i 0 ne {i xmark} if
3943       /i i xmkstep abs add store
3944       i n gt {exit} if
3945    } loop
3946 end
3947 } def
3948
3949 /ymkstep 1 def          % les marques sur Oy
3950 /setymkstep {
3951    /ymkstep exch def
3952 } def
3953 /ymark {
3954    dup ytick
3955    /Courier findfont .8 fontsize mul scalefont setfont
3956    dup chaine cvs exch
3957    Ox exch ymarkstyle
3958 } def
3959 /ymarks {
3960 2 dict begin
3961    /n ymax ymax ymin sub 1000 div sub ymkstep div truncate cvi
3962       ymkstep mul def                   % mark max
3963    /i ymin ymkstep div truncate cvi
3964       ymkstep mul def                   % la 1ere
3965    {
3966       i 0 ne {i ymark} if
3967       /i i ymkstep abs add store
3968       i n gt {exit} if
3969    } loop
3970 end
3971 } def
3972
3973 /setmkstep {
3974    setymkstep
3975    setxmkstep
3976 } def
3977 /marks {
3978    xmarks
3979    ymarks
3980 } def
3981
3982 %%%%% ### setfontsize ###
3983 /setfontsize {
3984    /fontsize exch def
3985 } def
3986
3987 %%%%% ### setCourrier ###
3988 /Courier findfont
3989 dup length dict begin
3990    {
3991    1 index /FID ne
3992       {def}
3993       {pop pop}
3994    ifelse
3995    } forall
3996    /Encoding ISOLatin1Encoding def
3997    currentdict
3998 end
3999
4000 /Courier-ISOLatin1 exch definefont pop
4001
4002 /setCourier {
4003    /Courier-ISOLatin1 findfont
4004    fontsize scalefont
4005    setfont
4006 } def
4007
4008 %%%%% ### pathtext ###
4009 %% syntaxe : string x y initp@thtext
4010  /initp@thtext {
4011 7 dict begin
4012    /y exch def
4013    /x exch def
4014    /str exch def
4015    str 0 0 show_dim
4016    /wy exch def
4017    /wx exch def
4018    /lly exch def
4019    /llx exch def
4020    pop pop pop
4021    newpath
4022       x y  smoveto
4023 } def
4024  /closep@thtext {
4025       str true charpath
4026 end
4027 } def
4028
4029 %% syntaxe : string x y cctext_
4030 /cctext_ {
4031    initp@thtext
4032    llx wx add lly wy add -.5 mulv rmoveto
4033    closep@thtext
4034 } def
4035
4036 /brtext_ {
4037    initp@thtext
4038    hadjust 0 rmoveto
4039    llx neg 0 rmoveto
4040    closep@thtext
4041 } def
4042
4043 /bbtext_ {
4044    initp@thtext
4045    0 0 rmoveto
4046    0 0 rmoveto
4047    closep@thtext
4048 } def
4049
4050 /bltext_ {
4051    initp@thtext
4052    hadjust neg 0 rmoveto
4053    wx neg 0 rmoveto
4054    closep@thtext
4055 } def
4056
4057 /bctext_ {
4058    initp@thtext
4059    0 0 rmoveto
4060    wx llx add -.5 mul 0 rmoveto
4061    closep@thtext
4062 } def
4063
4064 /ubtext_ {
4065    initp@thtext
4066    0 vadjust rmoveto
4067    0 lly neg rmoveto
4068    closep@thtext
4069 } def
4070
4071 /urtext_ {
4072    initp@thtext
4073    hadjust vadjust rmoveto
4074    llx neg lly neg rmoveto
4075    closep@thtext
4076 } def
4077
4078 /ultext_ {
4079    initp@thtext
4080    hadjust neg vadjust rmoveto
4081    wx neg lly neg rmoveto
4082    closep@thtext
4083 } def
4084
4085 /uctext_ {
4086    initp@thtext
4087    0 vadjust rmoveto
4088    llx wx add -.5 mul lly neg rmoveto
4089    closep@thtext
4090 } def
4091
4092 /drtext_ {
4093    initp@thtext
4094    hadjust vadjust neg rmoveto
4095    llx neg wy neg rmoveto
4096    closep@thtext
4097 } def
4098
4099 /dbtext_ {
4100    initp@thtext
4101    0 vadjust neg rmoveto
4102    0 wy neg rmoveto
4103    closep@thtext
4104 } def
4105
4106 /dltext_ {
4107    initp@thtext
4108    hadjust neg vadjust neg rmoveto
4109    wx neg wy neg rmoveto
4110    closep@thtext
4111 } def
4112
4113 /dctext_ {
4114    initp@thtext
4115    0 vadjust neg rmoveto
4116    llx wx add -2 div wy neg rmoveto
4117    closep@thtext
4118 } def
4119
4120 /crtext_ {
4121    initp@thtext
4122    hadjust 0 rmoveto
4123    llx neg lly wy add -2 div rmoveto
4124    closep@thtext
4125 } def
4126
4127 /cbtext_ {
4128    initp@thtext
4129    0 0 rmoveto
4130    0 lly wy add -2 div rmoveto
4131    closep@thtext
4132 } def
4133
4134 /cltext_ {
4135    initp@thtext
4136    hadjust neg 0 rmoveto
4137    wx neg lly wy add -2 div rmoveto
4138    closep@thtext
4139 } def
4140
4141 /cctext_ {
4142    initp@thtext
4143    0 0 rmoveto
4144    llx wx add lly wy add -.5 mulv rmoveto
4145    closep@thtext
4146 } def
4147
4148 %%%%% ### text3d ###
4149 %%%% Version 3d des commandes jps TEXTE
4150  /pr@p@re3d {
4151 2 dict begin
4152 %   /vect_echelle [1 1] def
4153 %   /angle_de_rot {0} def
4154 %   dup xcheck
4155 %      {/angle_de_rot exch def}
4156 %   if
4157 %   dup isarray
4158 %      {/vect_echelle exch def}
4159 %   if%   CamView vect_echelle {angle_de_rot}
4160    3dto2d
4161 } def
4162
4163 /bbtext3d {
4164    pr@p@re3d
4165    bbtext
4166 end
4167 } def
4168
4169 /bbtexlabel3d {
4170    pr@p@re3d
4171    bbtexlabel
4172 end
4173 } def
4174
4175 /bctext3d {
4176    pr@p@re3d
4177    bctext
4178 end
4179 } def
4180
4181 /bctexlabel3d {
4182    pr@p@re3d
4183    bctexlabel
4184 end
4185 } def
4186
4187 /bltext3d {
4188    pr@p@re3d
4189    bltext
4190 end
4191 } def
4192
4193 /bltexlabel3d {
4194    pr@p@re3d
4195    bltexlabel
4196 end
4197 } def
4198
4199 /brtext3d {
4200    pr@p@re3d
4201    brtext
4202 end
4203 } def
4204
4205 /brtexlabel3d {
4206    pr@p@re3d
4207    brtexlabel
4208 end
4209 } def
4210
4211 /cbtext3d {
4212    pr@p@re3d
4213    cbtext
4214 end
4215 } def
4216
4217 /cbtexlabel3d {
4218    pr@p@re3d
4219    cbtexlabel
4220 end
4221 } def
4222
4223 /cctext3d {
4224    pr@p@re3d
4225    cctext
4226 end
4227 } def
4228
4229 /cctexlabel3d {
4230    pr@p@re3d
4231    cctexlabel
4232 end
4233 } def
4234
4235 /cltext3d {
4236    pr@p@re3d
4237    cltext
4238 end
4239 } def
4240
4241 /cltexlabel3d {
4242    pr@p@re3d
4243    cltexlabel
4244 end
4245 } def
4246
4247 /crtext3d {
4248    pr@p@re3d
4249    crtext
4250 end
4251 } def
4252
4253 /crtexlabel3d {
4254    pr@p@re3d
4255    crtexlabel
4256 end
4257 } def
4258
4259 /dbtext3d {
4260    pr@p@re3d
4261    dbtext
4262 end
4263 } def
4264
4265 /dbtexlabel3d {
4266    pr@p@re3d
4267    dbtexlabel
4268 end
4269 } def
4270
4271 /dctext3d {
4272    pr@p@re3d
4273    dctext
4274 end
4275 } def
4276
4277 /dctexlabel3d {
4278    pr@p@re3d
4279    dctexlabel
4280 end
4281 } def
4282
4283 /dltext3d {
4284    pr@p@re3d
4285    dltext
4286 end
4287 } def
4288
4289 /dltexlabel3d {
4290    pr@p@re3d
4291    dltexlabel
4292 end
4293 } def
4294
4295 /drtext3d {
4296    pr@p@re3d
4297    drtext
4298 end
4299 } def
4300
4301 /drtexlabel3d {
4302    pr@p@re3d
4303    drtexlabel
4304 end
4305 } def
4306
4307 /ubtext3d {
4308    pr@p@re3d
4309    ubtext
4310 end
4311 } def
4312
4313 /ubtexlabel3d {
4314    pr@p@re3d
4315    ubtexlabel
4316 end
4317 } def
4318
4319 /uctext3d {
4320    pr@p@re3d
4321    uctext
4322 end
4323 } def
4324
4325 /uctexlabel3d {
4326    pr@p@re3d
4327    uctexlabel
4328 end
4329 } def
4330
4331 /ultext3d {
4332    pr@p@re3d
4333    ultext
4334 end
4335 } def
4336
4337 /ultexlabel3d {
4338    pr@p@re3d
4339    ultexlabel
4340 end
4341 } def
4342
4343 /urtext3d {
4344    pr@p@re3d
4345    urtext
4346 end
4347 } def
4348
4349 /urtexlabel3d {
4350    pr@p@re3d
4351    urtexlabel
4352 end
4353 } def
4354
4355 %%%%% ### fin insertion ###
4356
4357 %% La macro provisoire de developpement (27/01/2009)
4358 %% syntaxe : solid table tablez --> -
4359 /solidcolorz {
4360 10 dict begin
4361    %% les hauteurs
4362    /tablez exch def
4363    %% les couleurs
4364    /usertable exch def
4365    /solid exch def
4366    %% a-t-on des couleurs nommees ?
4367    usertable 0 get isstring {
4368       %% oui, et autant que d etages
4369       usertable length 1 sub tablez length eq {
4370          /table usertable def
4371       } {
4372          %% oui, mais moins que d etages
4373          %% ==> on definit les 2 premieres en RGB
4374          /a0 usertable 0 get def
4375          /a1 usertable 1 get def
4376          /lacouleurdepart {
4377             gsave
4378                [a0 cvx exec] length 0 eq {
4379                   a0 cvx exec currentrgbcolor
4380                } {
4381                   a0 cvx exec
4382                } ifelse
4383             grestore
4384          } def
4385          /lacouleurarrivee {
4386             gsave
4387                [a1 cvx exec] length 0 eq {
4388                   a1 cvx exec currentrgbcolor
4389                } {
4390                   a1 cvx exec
4391                } ifelse
4392             grestore
4393          } def
4394          /usertable [lacouleurdepart lacouleurarrivee] def
4395       } ifelse
4396    } if
4397    usertable 0 get isnum {
4398       %% c est un degrade : nb de couleurs a definir
4399       /n tablez length 1 add def
4400 %
4401       usertable length 4 eq {
4402           /a0 usertable 0 get def
4403           /a1 usertable 1 get def
4404           /A {a0 i a1 a0 sub mul n 1 sub div add} def
4405           /B usertable 2 get def
4406           /C usertable 3 get def
4407           /D {} def
4408           /espacedecouleurs (sethsbcolor) def
4409       } if
4410 %
4411       usertable length 6 eq {
4412           /a0 usertable 0 get def
4413           /b0 usertable 1 get def
4414           /c0 usertable 2 get def
4415           /a1 usertable 3 get def
4416           /b1 usertable 4 get def
4417           /c1 usertable 5 get def
4418           /A {a0 i a1 a0 sub mul n 1 sub div add} def
4419           /B {b0 i b1 b0 sub mul n 1 sub div add} def
4420           /C {c0 i c1 c0 sub mul n 1 sub div add} def
4421           /D {} def
4422           /espacedecouleurs (setrgbcolor) def
4423       } if
4424 %
4425       usertable length 7 eq {
4426           /a0 usertable 0 get def
4427           /b0 usertable 1 get def
4428           /c0 usertable 2 get def
4429           /a1 usertable 3 get def
4430           /b1 usertable 4 get def
4431           /c1 usertable 5 get def
4432           /A {a0 i a1 a0 sub mul n 1 sub div add} def
4433           /B {b0 i b1 b0 sub mul n 1 sub div add} def
4434           /C {c0 i c1 c0 sub mul n 1 sub div add} def
4435           /D {} def
4436           /espacedecouleurs (sethsbcolor) def
4437       } if
4438 %
4439       usertable length 8 eq {
4440           /a0 usertable 0 get def
4441           /b0 usertable 1 get def
4442           /c0 usertable 2 get def
4443           /d0 usertable 3 get def
4444           /a1 usertable 4 get def
4445           /b1 usertable 5 get def
4446           /c1 usertable 6 get def
4447           /d1 usertable 7 get def
4448           /A {a0 i a1 a0 sub mul n 1 sub div add} def
4449           /B {b0 i b1 b0 sub mul n 1 sub div add} def
4450           /C {c0 i c1 c0 sub mul n 1 sub div add} def
4451           /D {d0 i d1 d0 sub mul n 1 sub div add} def
4452           /espacedecouleurs (setcmykcolor) def
4453       } if
4454 %
4455       usertable length 2 eq {
4456          /a0 usertable 0 get def
4457          /a1 usertable 1 get def
4458          0 1 n 1 sub {
4459             /i exch def
4460             /A {a0 i a1 a0 sub mul n 1 sub div add} def
4461             /B {1} def
4462             /C {1} def
4463             /D {} def
4464             /espacedecouleurs (sethsbcolor) def
4465          } for
4466       } if
4467 %
4468       %% on affecte la table des couleurs
4469       /table [
4470          0 1 n 1 sub {
4471             /i exch def
4472             [A B C D] espacedecouleurs astr2str
4473          } for
4474       ] def
4475    } if
4476 %
4477    /n solid solidnombrefaces def
4478    0 1 n 1 sub {
4479       /i exch def
4480       solid i solidcentreface /z exch def pop pop
4481       /resultat 0 def
4482       0 1 tablez length 1 sub {
4483          /j exch def
4484          /ztest tablez j get def
4485          z ztest le {
4486             /resultat j store
4487             exit
4488          } {
4489             /resultat j 1 add store
4490          } ifelse
4491       } for
4492       solid i table resultat get solidputfcolor
4493    } for
4494 end
4495 } def
4496
4497
4498 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4499 %%%%             bibliotheque sur les solides           %%%%
4500 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4501
4502 %%%%% ### solide ###
4503 %% solid = [Sommets Faces Colors_Faces InOut_Table]
4504 /solidgetsommets {
4505    0 get
4506 } def
4507 /solidgetpointstable {solidgetsommets} def
4508
4509 /solidgetfaces {
4510    1 get
4511 } def
4512
4513 /solidgetface {
4514 1 dict begin
4515    /i exch def
4516    solidgetfaces i get
4517 end
4518 } def
4519
4520 /solidgetfcolors {
4521    2 get
4522 } def
4523
4524 %% syntaxe : solid i solidgetfcolor --> str
4525 /solidgetfcolor {
4526 1 dict begin
4527    /i exch def
4528    solidgetfcolors i get
4529 end
4530 } def
4531
4532 %% syntaxe : solid i str solidputfcolor --> -
4533 /solidputfcolor {
4534 2 dict begin
4535    /str exch def
4536    /i exch def
4537    solidgetfcolors i str put
4538 end
4539 } def
4540
4541 /solidgetinouttable {
4542    3 get
4543 } def
4544
4545 /solidputsommets {
4546    0 exch put
4547 } def
4548 /solidputpointstable {solidputsommets} def
4549
4550 /solidputfaces {
4551    1 exch put
4552 } def
4553
4554 %% syntaxe : solid solidfacesreverse -> -
4555 /solidfacesreverse {
4556 5 dict begin
4557    /solid exch def
4558    /n solid solidnombrefaces def
4559    0 1 n 1 sub {
4560       /i exch def
4561       /F solid i solidgetface reverse def
4562       /m F length def
4563       solid i [F aload pop m 0 roll ] solidputface
4564    } for
4565 end
4566 } def
4567
4568 /solidputfcolors {
4569    2 exch put
4570 } def
4571
4572 /solidputinouttable {
4573    3 exch put
4574 } def
4575
4576 %% syntaxe : any issolid --> booleen, vrai si any est de type solid
4577 /issolid {
4578 1 dict begin
4579    /candidat exch def
4580    candidat isarray {
4581       candidat length 4 eq {
4582          candidat 0 get isarray
4583          candidat 1 get isarray and
4584          candidat 2 get isarray and
4585          candidat 3 get isarray and {
4586             /IO candidat 3 get def
4587             IO length 4 eq
4588             IO 0 get isnum and
4589             IO 1 get isnum and
4590             IO 2 get isnum and
4591             IO 3 get isnum and
4592          } {
4593             false
4594          } ifelse
4595       } {
4596          false
4597       } ifelse
4598    } {
4599       false
4600    } ifelse
4601 end
4602 } def
4603
4604 /dupsolid {
4605 5 dict begin
4606    /solid exch def
4607    /S solid solidgetsommets def
4608    /F solid solidgetfaces def
4609    /FC solid solidgetfcolors def
4610    /IO solid solidgetinouttable def
4611    solid
4612    [
4613       S duparray exch pop
4614       F duparray exch pop
4615       FC duparray exch pop
4616       IO duparray exch pop
4617    ]
4618 end
4619 } def
4620
4621 %% syntaxe : solid array solidputinfaces --> -
4622 /solidputinfaces {
4623 4 dict begin
4624    /facesinternes exch def
4625    /solid exch def
4626    /n2 facesinternes length def
4627    /IO solid solidgetinouttable def
4628    /facesexternes solid solidgetoutfaces def
4629    /n1 facesexternes length def
4630    solid
4631       [facesexternes aload pop facesinternes aload pop]
4632       solidputfaces
4633    IO 0 0 put
4634    IO 1 n1 1 sub put
4635    IO 2 n1 put
4636    IO 3 n1 n2 add 1 sub put
4637 end
4638 } def
4639
4640 %% syntaxe : solid array solidputoutfaces --> -
4641 /solidputoutfaces {
4642 4 dict begin
4643    /facesexternes exch def
4644    /solid exch def
4645    /n1 facesexternes length def
4646    /IO solid solidgetinouttable def
4647    /facesinternes solid solidgetinfaces def
4648    /n2 facesinternes length def
4649    solid
4650       [facesexternes aload pop facesinternes aload pop]
4651       solidputfaces
4652    IO 0 0 put
4653    IO 1 n1 1 sub put
4654    IO 2 n1 put
4655    IO 3 n1 n2 add 1 sub put
4656 end
4657 } def
4658
4659 /solidnombreinfaces {
4660 1 dict begin
4661    /solid exch def
4662    solid solidwithinfaces {
4663       /IO solid solidgetinouttable def
4664       IO 3 get IO 2 get sub 1 add
4665    } {
4666       0
4667    } ifelse
4668 end
4669 } def
4670
4671 /solidnombreoutfaces {
4672 1 dict begin
4673    /solid exch def
4674    /IO solid solidgetinouttable def
4675    IO 1 get IO 0 get sub 1 add
4676 end
4677 } def
4678
4679 %% syntaxe : solid solidgetinfaces --> array
4680 /solidgetinfaces {
4681 4 dict begin
4682    /solid exch def
4683    solid issolid not {
4684       (Error : mauvais type d argument dans solidgetinfaces) ==
4685       quit
4686    } if
4687    solid solidwithinfaces {
4688       /IO solid solidgetinouttable def
4689       /F solid solidgetfaces def
4690       /n1 IO 2 get def
4691       /n2 IO 3 get def
4692       /n n2 n1 sub 1 add def
4693       F n1 n getinterval
4694    } {
4695       []
4696    } ifelse
4697 end
4698 } def
4699
4700 %% syntaxe : solid solidgetoutfaces --> array
4701 /solidgetoutfaces {
4702 4 dict begin
4703    /solid exch def
4704    solid issolid not {
4705       (Error : mauvais type d argument dans solidgetoutfaces) ==
4706       quit
4707    } if
4708    /IO solid solidgetinouttable def
4709    /F solid solidgetfaces def
4710    /n1 IO 0 get def
4711    /n2 IO 1 get def
4712    /n n2 n1 sub 1 add def
4713    F n1 n getinterval
4714 end
4715 } def
4716
4717 %% /tracelignedeniveau? false def
4718 %% /hauteurlignedeniveau 1 def
4719 %% /couleurlignedeniveau {rouge} def
4720 %% /linewidthlignedeniveau 4 def
4721
4722 /solidgridOn {
4723    /solidgrid true def
4724 } def
4725 /solidgridOff {
4726    /solidgrid false def
4727 } def
4728
4729 %% syntaxe : solid i string solidputfcolor
4730 %% syntaxe : solid str outputcolors
4731 %% syntaxe : solid str1 str2 inoutputcolors
4732 %% syntaxe : solid string n solidputncolors
4733 %% syntaxe : solid array solidputincolors --> -
4734 %% syntaxe : solid array solidputoutcolors --> -
4735 %% syntaxe : solid solidgetincolors --> array
4736 %% syntaxe : solid solidgetoutcolors --> array
4737
4738 %% syntaxe : solid array solidputinfaces --> -
4739 %% syntaxe : solid array solidputoutfaces --> -
4740 %% syntaxe : solid solidgetinfaces --> array
4741 %% syntaxe : solid solidgetoutfaces --> array
4742
4743 %% syntaxe : solid1 solid2 solidfuz -> solid
4744
4745 %% syntaxe : solid i solidgetsommetsface -> array
4746 %% array = tableau de points 3d
4747 /solidgetsommetsface {
4748 1 dict begin
4749    /i exch def
4750    /solid exch def
4751    /F solid i solidgetface def
4752    [
4753       0 1 F length 1 sub {
4754          /k exch def
4755          solid F k get solidgetsommet
4756       } for
4757    ]
4758 end
4759 } def
4760
4761 %% syntaxe : solid index table solidputface -> -
4762 /solidputface {
4763 1 dict begin
4764    /table exch def
4765    /i exch def
4766    solidgetfaces i table put
4767 end
4768 } def
4769
4770 %% syntaxe : solid table solidaddface -> -
4771 %% syntaxe : solid table (couleur) solidaddface -> -
4772 %% on ne se preoccupe pas des faces internes
4773 /solidaddface {
4774 6 dict begin
4775    dup isstring {
4776       /lac@uleur exch def
4777    } {
4778       /lac@uleur () def
4779    } ifelse
4780    /table exch def
4781    /solid exch def
4782    /IO solid solidgetinouttable def
4783    /n2 IO 1 get def
4784    /FC solid solidgetoutcolors def
4785    IO 1 n2 1 add put
4786    solid [ solid solidgetfaces aload pop table ] solidputfaces
4787    solid IO solidputinouttable
4788 %   solid solidnombrefaces
4789     solid [
4790       FC aload pop lac@uleur
4791     ] solidputoutcolors
4792 end
4793 } def
4794
4795 /solidnombrefaces {
4796 1 dict begin
4797    /solid exch def
4798    solid solidnombreinfaces
4799    solid solidnombreoutfaces
4800    add
4801 end
4802 } def
4803
4804 %% syntaxe : solid M solidaddsommetexterne -> -
4805 %% on ajoute le sommet sans se preoccuper de rien
4806 /solidaddsommetexterne {
4807 2 dict begin
4808    /M defpoint3d
4809    /solid exch def
4810    solid
4811    [ solid solidgetsommets aload pop M ]
4812    solidputsommets
4813 end
4814 } def
4815
4816 %% syntaxe : solid array solidaddsommets -> -
4817 /solidaddsommets {
4818 2 dict begin
4819    /table exch def
4820    /solid exch def
4821    /n table length 3 idiv def
4822    0 1 0 {
4823       /i exch def
4824       solid table i getp3d solidaddsommet pop
4825    } for
4826 end
4827 } def
4828
4829 %% syntaxe : solid M solidaddsommet -> k
4830 %% on ajoute le sommet M. Si il est deja sur une arete,
4831 %% on l incorpore a la face concernee
4832 %% s il est deja present, on ne le rajoute pas.
4833 %% Renvoie l indice du sommet rajoute.
4834 /solidaddsommet {
4835 10 dict begin
4836    /M defpoint3d
4837    /solid exch def
4838    /nbf solid solidnombrefaces def
4839    /N solid solidnombresommets def
4840    /sortie -1 def
4841    %% le sommet est-il deja dans la structure
4842    0 1 N 1 sub {
4843       /i exch def
4844 %%       (addsommet) ==
4845 %%       solid i solidgetsommet == == ==
4846 %%       M == == ==
4847 %%       solid i solidgetsommet M eqp3d ==
4848
4849 %      solid i solidgetsommet M eqp3d {
4850       solid i solidgetsommet M distance3d 1e-5 le {
4851          %% oui => c est fini
4852          /sortie i store
4853       } if
4854    } for
4855    sortie 0 lt {
4856       %% non => on le rajoute
4857       /sortie N def
4858       solid M solidaddsommetexterne
4859       %% est il sur une arete deja codee
4860       0 1 nbf 1 sub {
4861          %% face d indice i
4862          /i exch def
4863          solid i solidgetface /F exch def
4864          /nbsf F length def
4865          0 1 nbsf 1 sub {
4866             /j exch def
4867             M
4868             solid j i solidgetsommetface
4869             solid j 1 add nbsf mod i solidgetsommetface
4870             point3dsursegment {
4871                %% il est sur l arete concernee
4872                solid i [
4873                   0 1 j {
4874                      /k exch def
4875                      F k get
4876                   } for
4877                   N
4878                   j 1 add nbsf mod dup 0 eq {
4879                      pop
4880                   } {
4881                      1 nbsf 1 sub {
4882                         /k exch def
4883                         F k get
4884                      } for
4885                   } ifelse
4886                ]  solidputface
4887                exit
4888             } if
4889          } for
4890       } for
4891    } if
4892    sortie
4893 end
4894 } def
4895
4896 %%%%% ### solidrmsommet ###
4897 %% syntaxe : solid i solidrmsommet -> -
4898 /solidrmsommet {
4899 5 dict begin
4900    /i exch def
4901    /solid exch def
4902    solid issolid not {
4903       (Erreur : mauvais type d argument dans solidrmsommet) ==
4904       quit
4905    } if
4906    solid i solidsommetsadjsommet length 0 gt {
4907       (Erreur : sommet non isole dans solidrmsommet) ==
4908       quit
4909    } if
4910
4911    %% on s occupe des sommets
4912    /n solid solidnombresommets def
4913    /S [
4914       0 1 n 1 sub {
4915          /j exch def
4916          j i ne {
4917             solid j solidgetsommet
4918          } if
4919       } for
4920    ] def
4921    solid S solidputsommets
4922    %% on s occupe des faces
4923    /n solid solidnombrefaces def
4924    /F [
4925       0 1 n 1 sub {
4926          %% face d indice j
4927          /j exch def
4928          /Fj solid j solidgetface def
4929          [0 1 Fj length 1 sub {
4930             %% sommet d indice k de la face Fj
4931             /k exch def
4932             Fj k get dup i gt {
4933                1 sub
4934             } if
4935          } for]
4936       } for
4937    ] def
4938    solid F solidputfaces
4939 end
4940 } def
4941
4942 %%%%% ### solidsommetsadjsommet ###
4943 %% syntaxe : solid i solidsommetsadjsommet --> array
4944 %% array est le tableau des indices des sommets adjacents au
4945 %% sommet d indice i
4946 /solidsommetsadjsommet {
4947 6 dict begin
4948    /no exch def
4949    /solid exch def
4950    solid no solidfacesadjsommet /facesadj exch def
4951    /sommetsadj [] def
4952    /nbadj facesadj length def
4953    0 1 nbadj 1 sub {
4954       /j exch def
4955       %% examen de la jieme face
4956       %/j 0 def
4957       /F solid facesadj j get solidgetface def
4958       /nbsommetsface F length def
4959       no F in {
4960          /index exch def
4961          /i1 F index 1 sub nbsommetsface modulo get def
4962          /i2 F index 1 add nbsommetsface mod get def
4963          %% si i1 n est pas deja note, on le rajoute
4964          i1 sommetsadj in {
4965             pop
4966          } {
4967             /sommetsadj [ sommetsadj aload pop i1 ] store
4968          } ifelse
4969          %% si i2 n est pas deja note, on le rajoute
4970          i2 sommetsadj in {
4971             pop
4972          } {
4973             /sommetsadj [ sommetsadj aload pop i2 ] store
4974          } ifelse
4975       } {
4976          (Error : bug dans solidsommetsadjsommet) ==
4977          quit
4978       } ifelse
4979    } for
4980    sommetsadj
4981 end
4982 } def
4983
4984 %%%%% ### solidfacesadjsommet ###
4985 %% syntaxe : solid i solidfacesadjsommet --> array
4986 %% array est le tableau des indices des faces adjacentes au
4987 %% sommet d indice i
4988 /solidfacesadjsommet {
4989 6 dict begin
4990    /no exch def
4991    /solid exch def
4992    /n solid solidnombrefaces def
4993    /indicesfacesadj [] def
4994    0 1 n 1 sub {
4995       /j exch def
4996       /F solid j solidgetface def
4997       no F in {
4998          pop
4999          /indicesfacesadj [ indicesfacesadj aload pop j ] store
5000       } if
5001    } for
5002    indicesfacesadj
5003 end
5004 } def
5005
5006 %%%%% ### ordonnepoints3d ###
5007 %% syntaxe : array1 M ordonnepoints3d --> array2
5008 %% array1 = tableau de points 3d coplanaires (plan P)
5009 %% M = point3d indiquant la direction de la normale a P
5010 %% array2 = les indices des points de depart, ranges dans le
5011 %% sens trigo par rapport a la normale
5012 /ordonnepoints3d {
5013 5 dict begin
5014    /M defpoint3d
5015    /table exch def
5016    table isobarycentre3d /G defpoint3d
5017    %% calcul de la normale
5018    table 0 getp3d /ptref defpoint3d
5019    table 1 getp3d /A defpoint3d
5020    G ptref vecteur3d
5021    G A vecteur3d
5022    vectprod3d /vecteurnormal defpoint3d
5023    vecteurnormal G M vecteur3d scalprod3d 0 lt {
5024       vecteurnormal -1 mulv3d /vecteurnormal defpoint3d
5025    } if
5026    %% la table des angles
5027    table duparray exch pop
5028    {1 dict begin
5029       /M defpoint3d
5030       G ptref vecteur3d
5031       G M vecteur3d
5032       vecteurnormal angle3doriente
5033    end} papply3d
5034 %   [0 1 table length 3 idiv 1 sub {} for]
5035 %   exch
5036     doublebubblesort pop
5037 end
5038 } def
5039
5040 %%%%% ### fin insertion ###
5041
5042 %% /tracelignedeniveau? false def
5043 %% /hauteurlignedeniveau 1 def
5044 %% /couleurlignedeniveau {rouge} def
5045 %% /linewidthlignedeniveau 4 def
5046 %%
5047 %% /solidgrid true def
5048 %% /aretescachees true def
5049 %% /defaultsolidmode 2 def
5050
5051 %% syntaxe : alpha beta r h newpie --> solid
5052 /newpie {
5053 6 dict begin
5054    [[/resolution /nbetages] [8 1] [10 1] [12 1] [18 3] [36 5]] gestionsolidmode
5055    /h exch def
5056    /r exch def
5057    /beta exch def
5058    /alpha exch def
5059    [
5060       0 0
5061 %      alpha cos r mul alpha sin r mul
5062       alpha beta {1 dict begin /t exch def t cos r mul t sin r mul end} CourbeR2+
5063    ] 0 h [nbetages] newprismedroit
5064 end
5065 } def
5066
5067 %%%%% ### newsolid ###
5068 %% syntaxe : newsolid --> depose le solide nul sur la pile
5069 /newsolid {
5070    [] [] generesolid
5071 } def
5072
5073 %%%%% ### generesolid ###
5074 /generesolid {
5075 2 dict begin
5076    /F exch def
5077    /S exch def
5078    [S F [F length {()} repeat] [0 F length 1 sub -1 -1]]
5079 end
5080 } def
5081
5082 %%%%% ### nullsolid ###
5083 %% syntaxe : solide nullsolid -> booleen, vrai si le solide est nul
5084 /nullsolid {
5085 1 dict begin
5086    /candidat exch def
5087    candidat issolid not {
5088       (Error type argument dans "nullsolid") ==
5089       quit
5090    } if
5091    candidat solidgetsommets length 0 eq {
5092       true
5093    } {
5094       false
5095    } ifelse
5096 end
5097 } def
5098
5099 %%%%% ### solidnombreoutfaces ###
5100 /solidnombreoutfaces {
5101 4 dict begin
5102    /solid exch def
5103    solid issolid not {
5104       (Error : mauvais type d argument dans solidnombreoutfaces) ==
5105       quit
5106    } if
5107    solid nullsolid {
5108       0
5109    } {
5110       /IO solid solidgetinouttable def
5111       IO 1 get
5112       IO 0 get sub
5113       1 add
5114    } ifelse
5115 end
5116 } def
5117
5118 %%%%% ### solidnombreinfaces ###
5119 /solidnombreinfaces {
5120 4 dict begin
5121    /solid exch def
5122    solid issolid not {
5123       (Error : mauvais type d argument dans solidnombreinfaces) ==
5124       quit
5125    } if
5126    solid solidwithinfaces {
5127       /IO solid solidgetinouttable def
5128       IO 3 get
5129       IO 2 get sub
5130       1 add
5131    } {
5132       0
5133    } ifelse
5134 end
5135 } def
5136
5137 %%%%% ### solidtests ###
5138 %% syntaxe : solid solidwithinfaces --> bool, true si le solide est vide
5139 /solidwithinfaces {
5140 2 dict begin
5141    /solid exch def
5142    solid issolid not {
5143       (Error : mauvais type d argument dans solidwithinfaces) ==
5144       quit
5145    } if
5146    /table solid solidgetinouttable def
5147    table 2 get -1 ne {
5148       true
5149    } {
5150       false
5151    } ifelse
5152 end
5153 } def
5154
5155 %%%%% ### solidgetsommet ###
5156 %% syntaxe : solid i j solidgetsommetface --> sommet i de la face j
5157 /solidgetsommetface {
5158 6 dict begin
5159    /j exch def
5160    /i exch def
5161    /solid exch def
5162    solid issolid not {
5163       (Error : mauvais type d argument dans solidgetsommetface) ==
5164       quit
5165    } if
5166    /table_faces solid solidgetfaces def
5167    /table_sommets solid solidgetsommets def
5168    /k table_faces j get i get def
5169    table_sommets k getp3d
5170 end
5171 } def
5172
5173 %% syntaxe : solid i solidgetsommetsface --> array, tableau des
5174 %% sommets de la face i du solide
5175 /solidgetsommetsface {
5176 6 dict begin
5177    /i exch def
5178    /solid exch def
5179    solid issolid not {
5180       (Error : mauvais type d argument dans solidgetsommetsface) ==
5181       quit
5182    } if
5183    /table_faces solid solidgetfaces def
5184    /table_sommets solid solidgetsommets def
5185    /table_indices table_faces i get def
5186    [
5187       0 1 table_indices length 1 sub {
5188          /j exch def
5189          table_sommets table_indices j get getp3d
5190       } for
5191    ]
5192 end
5193 } def
5194
5195 %% syntaxe : solid i solidgetsommet --> sommet i du solide
5196 /solidgetsommet {
5197 3 dict begin
5198    /i exch def
5199    /solid exch def
5200    solid issolid not {
5201       (Error : mauvais type d argument dans solidgetsommet) ==
5202       quit
5203    } if
5204    /table_sommets solid solidgetsommets def
5205    table_sommets i getp3d
5206 end
5207 } def
5208
5209 %%%%% ### solidcentreface ###
5210 %% syntaxe : solid i solidcentreface --> M
5211 /solidcentreface {
5212    solidgetsommetsface isobarycentre3d
5213 } def
5214
5215 %%%%% ### solidnombre ###
5216 /solidnombresommets {
5217    solidgetsommets length 3 idiv
5218 } def
5219
5220 /solidfacenombresommets {
5221    solidgetface length
5222 } def
5223
5224 /solidnombrefaces {
5225    solidgetfaces length
5226 } def
5227
5228 %%%%% ### solidshowsommets ###
5229 /solidshowsommets {
5230 8 dict begin
5231    dup issolid not {
5232       %% on a un argument
5233       /option exch def
5234    } if
5235    /sol exch def
5236    /n sol solidnombresommets def
5237    /m sol solidnombrefaces def
5238    currentdict /option known not {
5239       /option [0 1 n 1 sub {} for] def
5240    } if
5241    0 1 option length 1 sub {
5242       /k exch def
5243       option k get /i exch def       %% indice du sommet examine
5244       sol i solidgetsommet point3d
5245    } for
5246 end
5247 } def
5248
5249 %%%%% ### solidnumsommets ###
5250 /solidnumsep 15 def
5251 /solidnumsommets {
5252 8 dict begin
5253 %   Font findfont 10 scalefont setfont
5254    dup issolid not {
5255       %% on a un argument
5256       /option exch def
5257    } if
5258    /sol exch def
5259    /n sol solidnombresommets def
5260    /m sol solidnombrefaces def
5261    currentdict /option known not {
5262       /option [0 1 n 1 sub {} for] def
5263    } if
5264    /result [
5265       n {false} repeat
5266    ] def
5267    0 1 option length 1 sub {
5268       /k exch def
5269       option k get /i exch def       %% indice du sommet examine
5270       0 1 m 1 sub {
5271          /j exch def %% indice de la face examinee
5272          i sol j solidgetface in {
5273             %% le sommet i est dans la face j
5274             pop
5275             exit
5276          } if
5277       } for
5278       sol i solidgetsommet /S defpoint3d
5279       i (   ) cvs
5280       m 0 ne {
5281          %% le sommet i est dans la face j
5282          sol j solidcentreface /G defpoint3d
5283          G S vecteur3d normalize3d
5284          solidnumsep dup ptojpoint pop
5285          mulv3d
5286          S addv3d
5287          3dto2d cctext
5288       } {
5289          S 3dto2d uctext
5290       } ifelse
5291    } for
5292 end
5293 } def
5294
5295 %%%%% ### gestionsolidmode ###
5296 %% table = [ [vars] [mode0] [mode1] [mode2] [mode3] [mode4] ]
5297 /gestionsolidmode {
5298 5 dict begin
5299    /table exch def
5300    dup xcheck {
5301       /mode exch def
5302    } {
5303       dup isarray {
5304          /tableaffectation exch def
5305          /mode -1 def
5306       } {
5307          /mode defaultsolidmode def
5308       } ifelse
5309    } ifelse
5310    /vars table 0 get def
5311    /nbvars vars length def
5312    mode 0 ge {
5313       /tableaffectation table mode 1 add 5 min get def
5314    } if
5315    0 1 nbvars 1 sub {
5316       /i exch def
5317       vars i get
5318       tableaffectation i get
5319    } for
5320    nbvars
5321 end
5322    {def} repeat
5323 } def
5324
5325 %%%%% ### solidfuz ###
5326 %% syntaxe : solid1 solid2 solidfuz -> solid
5327 /solidfuz {
5328 5 dict begin
5329    /solid2 exch def
5330    /solid1 exch def
5331    /S1 solid1 solidgetsommets def
5332    /S2 solid2 solidgetsommets def
5333    /n S1 length 3 idiv def
5334
5335    %% les sommets
5336    /S S1 S2 append def
5337
5338    %% les faces internes et leurs couleurs
5339    /FI1 solid1 solidgetinfaces def
5340    /FIC1 solid1 solidgetincolors def
5341    solid2 solidnombreinfaces 0 eq {
5342       /FI2 [] def
5343       /FIC2 [] def
5344    } {
5345       /FI2 solid2 solidgetinfaces {{n add} apply} apply def
5346       /FIC2 solid2 solidgetincolors def
5347    } ifelse
5348    /FI [FI1 aload pop FI2 aload pop] def
5349    /FIC [FIC1 aload pop FIC2 aload pop] def
5350
5351    %% les faces externes et leurs couleurs
5352    /FO1 solid1 solidgetoutfaces def
5353    /FOC1 solid1 solidgetoutcolors def
5354    /FO2 solid2 solidgetoutfaces {{n add} apply} apply def
5355    /FOC2 solid2 solidgetoutcolors def
5356    /FO [FO1 aload pop FO2 aload pop] def
5357    /FOC [FOC1 aload pop FOC2 aload pop] def
5358
5359    /F [FO aload pop FI aload pop] def
5360    /FC [FOC aload pop FIC aload pop] def
5361    /IO [
5362       0 FO length 1 sub
5363       FI length 0 gt {
5364          dup 1 add dup FI length add 1 sub
5365       } {
5366          -1 -1
5367       } ifelse
5368    ] def
5369
5370    S F generesolid
5371    dup FC solidputfcolors
5372    dup IO solidputinouttable
5373 end
5374 } def
5375
5376 %%%%% ### solidnormaleface ###
5377 %% syntaxe : solid i solidnormaleface --> u, vecteur normale a la
5378 %% face d indice i du solide
5379 /solidnormaleface {
5380 4 dict begin
5381    /i exch def
5382    /solid exch def
5383    solid issolid not {
5384       (Error : mauvais type d argument dans solidgetsommetface) ==
5385       quit
5386    } if
5387 %%    solid 0 i solidgetsommetface /G defpoint3d
5388 %%    G
5389 %%    solid 1 i solidgetsommetface
5390 %%    vecteur3d
5391 %%    G
5392 %%    solid 2 i solidgetsommetface
5393 %%    vecteur3d
5394 %
5395    /n solid i solidfacenombresommets def
5396    n 3 ge {
5397       [
5398          solid 0 i solidgetsommetface
5399          solid 1 i solidgetsommetface
5400          solid 2 i solidgetsommetface
5401       ] isobarycentre3d /G defpoint3d
5402    } {
5403       solid i solidcentreface /G defpoint3d
5404    } ifelse
5405   %% debug %%   G 3dto2d point
5406    G
5407    solid 0 i solidgetsommetface
5408    /A defpoint3d
5409   %   gsave bleu A point3d grestore
5410    A
5411    vecteur3d normalize3d
5412    G
5413    solid 1 i solidgetsommetface
5414    /A defpoint3d
5415   %   gsave orange A point3d grestore
5416    A
5417    vecteur3d normalize3d
5418    vectprod3d
5419    /resultat defpoint3d
5420    resultat normalize3d
5421 end
5422 } def
5423
5424 %%%%% ### solidtransform ###
5425 %% syntaxe : solid1 {f} solidtransform --> solid2, solid2 est le
5426 %% transforme de solid1 par la transformation f : R^3 -> R^3
5427 /solidtransform {
5428 3 dict begin
5429    /@f exch def
5430    /solid exch def
5431    solid issolid not {
5432       (Error : mauvais type d argument dans solidtransform) ==
5433       quit
5434    } if
5435    /les_sommets
5436       solid solidgetsommets {@f} papply3d
5437    def
5438    solid les_sommets solidputsommets
5439    solid
5440 end
5441 } def
5442
5443 %%%%% ### solidputcolor ###
5444 %% syntaxe : solid i string solidputfcolor
5445 /solidputfcolor {
5446 3 dict begin
5447    /str exch def
5448    /i exch def
5449    /solid exch def
5450    /FC solid solidgetfcolors def
5451    i FC length lt {
5452       FC i str put
5453    } if
5454 end
5455 } def
5456
5457 %% syntaxe : solid solidgetincolors --> array
5458 /solidgetincolors {
5459 3 dict begin
5460    /solid exch def
5461    solid issolid not {
5462       (Error : mauvais type d argument dans solidgetincolors) ==
5463       quit
5464    } if
5465    solid solidwithinfaces {
5466       /fcol solid solidgetfcolors def
5467       /IO solid solidgetinouttable def
5468       /n1 IO 2 get def
5469       /n2 IO 3 get def
5470       /n n2 n1 sub 1 add def
5471       fcol n1 n getinterval
5472    } {
5473       []
5474    } ifelse
5475 end
5476 } def
5477
5478 %% syntaxe : solid solidgetoutcolors --> array
5479 /solidgetoutcolors {
5480 3 dict begin
5481    /solid exch def
5482    solid issolid not {
5483       (Error : mauvais type d argument dans solidgetoutcolors) ==
5484       quit
5485    } if
5486    /fcol solid solidgetfcolors def
5487    /IO solid solidgetinouttable def
5488    /n1 IO 0 get def
5489    /n2 IO 1 get def
5490    /n n2 n1 sub 1 add def
5491    fcol n1 n getinterval
5492 end
5493 } def
5494
5495 %% syntaxe : solid array solidputincolors --> -
5496 /solidputincolors {
5497 4 dict begin
5498    /newcolorstable exch def
5499    /solid exch def
5500    solid issolid not {
5501       (Error : mauvais type d argument dans solidputincolors) ==
5502       quit
5503    } if
5504    /n newcolorstable length def
5505    n solid solidnombreinfaces ne {
5506       (Error : mauvaise longueur de tableau dans solidputincolors) ==
5507       quit
5508    } if
5509    n 0 ne {
5510       /FC solid solidgetfcolors def
5511       /IO solid solidgetinouttable def
5512       /n1 IO 2 get def
5513       FC n1 newcolorstable putinterval
5514    } if
5515 end
5516 } def
5517
5518 %% syntaxe : solid array solidputoutcolors --> -
5519 /solidputoutcolors {
5520 4 dict begin
5521    /newcolorstable exch def
5522    /solid exch def
5523    solid issolid not {
5524       (Error : mauvais type d argument dans solidputoutcolors) ==
5525       quit
5526    } if
5527    /n newcolorstable length def
5528    n solid solidnombreoutfaces ne {
5529       (Error : mauvaise longueur de tableau dans solidputoutcolors) ==
5530       quit
5531    } if
5532    n 0 ne {
5533       /FC solid solidgetfcolors def
5534       /IO solid solidgetinouttable def
5535       /n1 IO 0 get def
5536       FC n1 newcolorstable putinterval
5537    } if
5538 end
5539 } def
5540
5541 %% syntaxe : solid str outputcolors
5542 /outputcolors {
5543 5 dict begin
5544    /color exch def
5545    /solid exch def
5546    solid issolid not {
5547       (Error : mauvais type d argument dans inoutputcolors) ==
5548       quit
5549    } if
5550    /n solid solidnombreoutfaces def
5551    solid [ n {color} repeat ] solidputoutcolors
5552 end
5553 } def
5554
5555 %% syntaxe : solid str inputcolors
5556 /inputcolors {
5557 5 dict begin
5558    /color exch def
5559    /solid exch def
5560    solid issolid not {
5561       (Error : mauvais type d argument dans inoutputcolors) ==
5562       quit
5563    } if
5564    /n solid solidnombreinfaces def
5565    solid [ n {color} repeat ] solidputincolors
5566 end
5567 } def
5568
5569 %% syntaxe : solid str1 str2 inoutputcolors
5570 /inoutputcolors {
5571 5 dict begin
5572    /colout exch def
5573    /colin exch def
5574    /solid exch def
5575    solid colin inputcolors
5576    solid colout outputcolors
5577 end
5578 } def
5579
5580 %% syntaxe : solid array solidputoutcolors --> -
5581 /solidputoutcolors {
5582 4 dict begin
5583    /newcolorstable exch def
5584    /solid exch def
5585    solid issolid not {
5586       (Error : mauvais type d argument dans solidputoutcolors) ==
5587       quit
5588    } if
5589    /n newcolorstable length def
5590    n solid solidnombreoutfaces ne {
5591       (Error : mauvaise longueur de tableau dans solidputoutcolors) ==
5592       quit
5593    } if
5594    n 0 ne {
5595       /FC solid solidgetfcolors def
5596       /IO solid solidgetinouttable def
5597       /n1 IO 0 get def
5598       FC length n n1 add lt {
5599          solid newcolorstable solidputfcolors
5600       } {
5601          FC n1 newcolorstable putinterval
5602       } ifelse
5603    } if
5604 end
5605 } def
5606
5607 /solidputcolors {
5608 3 dict begin
5609    2 copy pop
5610    isstring {
5611       inoutputcolors
5612    } {
5613       outputcolors
5614    } ifelse
5615 end
5616 } def
5617
5618 %%%%% ### solidputhuecolors ###
5619 %% syntaxe : solid table solidputhuecolors --> -
5620 /solidputhuecolors {
5621 1 dict begin
5622    2 copy pop
5623    solidgetinouttable /IO exch def
5624    IO 0 get
5625    IO 1 get
5626    s@lidputhuec@l@rs
5627 end
5628 } def
5629
5630 /solidputinhuecolors {
5631 2 dict begin
5632    /table exch def
5633    /solid exch def
5634    solid solidgetinouttable /IO exch def
5635    solid solidwithinfaces {
5636       solid table
5637       IO 2 get
5638       IO 3 get
5639       s@lidputhuec@l@rs
5640    } if
5641 end
5642 } def
5643
5644 /solidputinouthuecolors {
5645 1 dict begin
5646    2 copy pop
5647    solidgetinouttable /IO exch def
5648    IO 0 get
5649    IO 3 get IO 1 get max
5650    s@lidputhuec@l@rs
5651 end
5652 } def
5653
5654 %% syntaxe : solid table n1 n2 s@lidputhuec@l@rs --> -
5655 %% affecte les couleurs des faces d indice n1 a n2 du solid solid, par
5656 %% un degrade defini par la table.
5657  /s@lidputhuec@l@rs {
5658 9 dict begin
5659    /n2 exch def
5660    /n1 exch def
5661    /table exch def
5662    /solid exch def
5663    /n n2 n1 sub def
5664
5665    table length 2 eq {
5666        /a0 table 0 get def
5667        /a1 table 1 get def
5668        a1 isstring {
5669           /lacouleurdepart {
5670              gsave
5671                 [a0 cvx exec] length 0 eq {
5672                    a0 cvx exec currentrgbcolor
5673                 } {
5674                    a0 cvx exec
5675                 } ifelse
5676              grestore
5677           } def
5678           /lacouleurarrivee {
5679              gsave
5680                 [a1 cvx exec] length 0 eq {
5681                    a1 cvx exec currentrgbcolor
5682                 } {
5683                    a1 cvx exec
5684                 } ifelse
5685              grestore
5686           } def
5687           /table [lacouleurdepart lacouleurarrivee] def
5688        } {
5689           /A {a0 i a1 a0 sub mul n 1 sub div add} def
5690           /B {1} def
5691           /C {1} def
5692           /D {} def
5693           /espacedecouleurs (sethsbcolor) def
5694        } ifelse
5695    } if
5696
5697    table length 4 eq {
5698        /a0 table 0 get def
5699        /a1 table 1 get def
5700        /A {a0 i a1 a0 sub mul n 1 sub div add} def
5701        /B table 2 get def
5702        /C table 3 get def
5703        /D {} def
5704        /espacedecouleurs (sethsbcolor) def
5705    } if
5706
5707    table length 6 eq {
5708        /a0 table 0 get def
5709        /b0 table 1 get def
5710        /c0 table 2 get def
5711        /a1 table 3 get def
5712        /b1 table 4 get def
5713        /c1 table 5 get def
5714        /A {a0 i a1 a0 sub mul n 1 sub div add} def
5715        /B {b0 i b1 b0 sub mul n 1 sub div add} def
5716        /C {c0 i c1 c0 sub mul n 1 sub div add} def
5717        /D {} def
5718        /espacedecouleurs (setrgbcolor) def
5719    } if
5720
5721    table length 7 eq {
5722        /a0 table 0 get def
5723        /b0 table 1 get def
5724        /c0 table 2 get def
5725        /a1 table 3 get def
5726        /b1 table 4 get def
5727        /c1 table 5 get def
5728        /A {a0 i a1 a0 sub mul n 1 sub div add} def
5729        /B {b0 i b1 b0 sub mul n 1 sub div add} def
5730        /C {c0 i c1 c0 sub mul n 1 sub div add} def
5731        /D {} def
5732        /espacedecouleurs (sethsbcolor) def
5733    } if
5734
5735    table length 8 eq {
5736        /a0 table 0 get def
5737        /b0 table 1 get def
5738        /c0 table 2 get def
5739        /d0 table 3 get def
5740        /a1 table 4 get def
5741        /b1 table 5 get def
5742        /c1 table 6 get def
5743        /d1 table 7 get def
5744        /A {a0 i a1 a0 sub mul n 1 sub div add} def
5745        /B {b0 i b1 b0 sub mul n 1 sub div add} def
5746        /C {c0 i c1 c0 sub mul n 1 sub div add} def
5747        /D {d0 i d1 d0 sub mul n 1 sub div add} def
5748        /espacedecouleurs (setcmykcolor) def
5749    } if
5750
5751    n1 1 n2 {
5752       /i exch def
5753       solid i
5754       [A B C D] espacedecouleurs astr2str
5755       solidputfcolor
5756    } for
5757
5758 end
5759 } def
5760
5761 %%%%% ### solidrmface ###
5762 %% syntaxe : solid i solidrmface -> -
5763 /solidrmface {
5764 5 dict begin
5765    /i exch def
5766    /solid exch def
5767    solid issolid not {
5768       (Error : mauvais type d argument dans solidrmface) ==
5769       quit
5770    } if
5771    %% on enleve la face
5772    /F solid solidgetfaces def
5773    F length 1 sub i lt {
5774       (Error : indice trop grand dans solidrmface) ==
5775       quit
5776    } if
5777    [
5778       0 1 F length 1 sub {
5779          /j exch def
5780          i j ne {
5781             F j get
5782          } if
5783       } for
5784    ]
5785    /NF exch def
5786    solid NF solidputfaces
5787    %% on enleve la couleur correspondante
5788    /FC solid solidgetfcolors def
5789    [
5790       0 1 FC length 1 sub {
5791          /j exch def
5792          i j ne {
5793             FC j get
5794          } if
5795       } for
5796    ]
5797    /NFC exch def
5798    solid NFC solidputfcolors
5799    %% on ajuste la table inout
5800    /IO solid solidgetinouttable def
5801    solid i solidisoutface {
5802       IO 1 IO 1 get 1 sub put
5803       solid solidwithinfaces {
5804          IO 2 IO 2 get 1 sub put
5805          IO 3 IO 3 get 1 sub put
5806       } if
5807    } if
5808    solid i solidisinface {
5809       IO 1 IO 1 get 1 sub put
5810       IO 2 IO 2 get 1 sub put
5811       IO 3 IO 3 get 1 sub put
5812    } if
5813    solid IO solidputinouttable
5814 end
5815 } def
5816
5817 %% syntaxe : solid table solidrmfaces --> -
5818 /solidrmfaces {
5819 2 dict begin
5820    /table exch bubblesort reverse def
5821    /solid exch def
5822    table {solid exch solidrmface} apply
5823 end
5824 } def
5825
5826 %%%%% ### videsolid ###
5827 %% syntaxe : solid videsolid -> -
5828 /videsolid {
5829 5 dict begin
5830    /solid exch def
5831    solid issolid not {
5832       (Error : mauvais type d argument dans videsolid) ==
5833       quit
5834    } if
5835    solid solidwithinfaces not {
5836       /IO solid solidgetinouttable def
5837       /FE solid solidgetfaces def
5838       /n FE length def
5839       IO 2 n put
5840       IO 3 2 n mul 1 sub put
5841       solid IO solidputinouttable
5842       %% on inverse chaque face
5843       /FI FE {reverse} apply def
5844       solid FE FI append solidputfaces
5845       %% et on rajoute autant de couleurs vides que de faces
5846       /FEC solid solidgetfcolors def
5847 %      /FIC [FI length {()} repeat] def
5848 %      solid FEC FIC append solidputfcolors
5849       solid FEC duparray append solidputfcolors
5850    } if
5851 end
5852 } def
5853
5854 %%%%% ### solidnumfaces ###
5855 %% syntaxe : solid array solidnumfaces
5856 %% syntaxe : solid array bool solidnumfaces
5857 %% array, le tableau des indices des faces a numeroter, est optionnel
5858 %% si bool=true, on ne numerote que les faces visibles
5859 /solidnumfaces {
5860 5 dict begin
5861    dup isbool {
5862       /bool exch def
5863    } {
5864       /bool true def
5865    } ifelse
5866 %   setTimes
5867    dup issolid not {
5868       %% on a un argument
5869       /option exch def
5870    } if
5871    /sol exch def
5872    /n sol solidnombrefaces def
5873    currentdict /option known not {
5874       /option [0 1 n 1 sub {} for] def
5875    } if
5876
5877    0 1 option length 1 sub {
5878       /i exch def
5879       /j option i get def
5880       j (     ) cvs sol j bool cctextp3d
5881    } for
5882 end
5883 } def
5884
5885 %%%%% ### creusesolid ###
5886 %% syntaxe : solid creusesolid -> -
5887 /creusesolid {
5888 5 dict begin
5889    /solid exch def
5890    solid issolid not {
5891       (Error : mauvais type d argument dans creusesolid) ==
5892       quit
5893    } if
5894    %% on enleve le fond et le chapeau
5895    solid 1 solidrmface
5896    solid 0 solidrmface
5897    %% on inverse chaque face
5898    solid videsolid
5899 end
5900 } def
5901
5902 %%%%% ### fin insertion ###
5903
5904 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5905 %%%%                 dessin des solides                 %%%%
5906 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5907
5908 %%%%% ### solidisinface ###
5909 %% syntaxe : solid i solidisinface --> bool
5910 %% true si i est l indice d une face interne, false sinon
5911 /solidisinface {
5912 4 dict begin
5913    /i exch def
5914    solidgetinouttable /IO exch def
5915    /n1 IO 2 get def
5916    /n2 IO 3 get def
5917    n1 i le
5918    i n2 le and
5919 end
5920 } def
5921
5922 %%%%% ### solidisoutface ###
5923 %% syntaxe : solid i solidisoutface --> bool
5924 %% true si i est l indice d une face externe, false sinon
5925 /solidisoutface {
5926 4 dict begin
5927    /i exch def
5928    solidgetinouttable /IO exch def
5929    /n1 IO 0 get def
5930    /n2 IO 1 get def
5931    n1 i le
5932    i n2 le and
5933 end
5934 } def
5935
5936 %%%%% ### planvisible ###
5937 %% syntaxe : A k planvisible? --> true si le plan est visible
5938 /planvisible? {
5939 4 dict begin
5940    /normale_plan defpoint3d
5941    /origine defpoint3d
5942    /ligne_de_vue {
5943       origine
5944       GetCamPos
5945       vecteur3d
5946    } def
5947    ligne_de_vue normale_plan scalprod3d 0 gt
5948 end
5949 } def
5950
5951 %%%%% ### solidlight ###
5952 /setlightintensity {
5953    /lightintensity exch def
5954 } def
5955
5956 /setlightsrc {
5957    /lightsrc defpoint3d
5958 } def
5959
5960 /setlight {
5961 1 dict begin
5962 gsave
5963    exec
5964    [ currentrgbcolor ] /lightcolor exch
5965 grestore
5966 end
5967 def
5968 } def
5969
5970 %%%%% ### drawsolid ###
5971 /solidlightOn {
5972    /s@lidlight true def
5973 } def
5974 /solidlightOff {
5975    /s@lidlight false def
5976 } def
5977 solidlightOff
5978
5979 %% syntaxe : solid i solidfacevisible? --> true si la face est visible
5980 /solidfacevisible? {
5981 4 dict begin
5982    /i exch def
5983    /solid exch def
5984    solid issolid not {
5985       (Error : mauvais type d argument dans solidgetsommetface) ==
5986       quit
5987    } if
5988    solid i solidgetface length 2 le {
5989       true
5990    } {
5991       /ligne_de_vue {
5992          solid i solidcentreface
5993          GetCamPos
5994          vecteur3d
5995       } def
5996
5997       /normale_face {
5998          solid i solidnormaleface
5999       } def
6000       ligne_de_vue normale_face scalprod3d 0 gt
6001    } ifelse
6002 end
6003 } def
6004
6005 %% syntaxe : solid i affectecouleursolid_facei --> si la couleur de
6006 %% la face i est definie, affecte fillstyle a cette couleur
6007 /affectecouleursolid_facei {
6008 3 dict begin
6009    /i exch def
6010    /solid exch def
6011    solid solidgetfcolors /FC exch def
6012    FC length 1 sub i ge {
6013       FC i get length 1 ge {
6014          /fillstyle FC i get ( Fill) append cvx
6015          solidgrid not {
6016             FC i get cvx exec
6017          } if
6018          true
6019       } {
6020          false
6021       } ifelse
6022    } {
6023       false
6024    } ifelse
6025 end
6026 {def} if
6027 } def
6028
6029 %% syntaxe : solid i dessinefacecachee
6030 /dessinefacecachee {
6031 11 dict begin
6032    /i exch def
6033    /solid exch def
6034    solid issolid not {
6035       (Error : mauvais type d argument dans dessinefacecachee) ==
6036       quit
6037    } if
6038
6039    /F solid solidgetfaces def
6040    /S solid solidgetsommets def
6041
6042    %% face cachee => on prend chacune des aretes de la face et on
6043    %% la dessine
6044    4 dict begin
6045       /n F i get length def %% nb de sommets de la face
6046       0 1 n 1 sub {
6047          /k exch def
6048          /k1 F i k get_ij def              %% indice sommet1
6049          /k2 F i k 1 add n mod get_ij def  %% indice sommet2
6050          gsave
6051             currentlinewidth .5 mul setlinewidth
6052             pointilles
6053             [S k1 getp3d
6054             S k2 getp3d sortp3d] ligne3d
6055          grestore
6056       } for
6057
6058    %% trace de la ligne de niveau
6059    solidintersectiontype 0 ge {
6060       /face_a_dessiner [  %% face visible : F [i]
6061          0 1 n 1 sub {
6062             /j exch def
6063             solid j i solidgetsommetface
6064          } for
6065       ] def
6066       0 1 solidintersectionplan length 1 sub {
6067          /k exch def
6068          /lignedeniveau [] def
6069          gsave
6070             solidintersectiontype 0 eq {
6071                pointilles
6072             } {
6073                continu
6074             } ifelse
6075             k solidintersectionlinewidth length lt {
6076                solidintersectionlinewidth k get setlinewidth
6077             } {
6078                solidintersectionlinewidth 0 get setlinewidth
6079             } ifelse
6080             k solidintersectioncolor length lt {
6081                solidintersectioncolor k get cvx exec
6082             } {
6083                solidintersectioncolor 0 get cvx exec
6084             } ifelse
6085             0 1 n 1 sub {
6086                /j exch def
6087                face_a_dessiner j getp3d
6088                face_a_dessiner j 1 add n mod getp3d
6089                solidintersectionplan k get
6090                dup isarray {
6091                   segment_inter_plan
6092                } {
6093                   segment_inter_planz
6094                } ifelse {
6095                1 dict begin
6096                   /table exch def
6097                   table length 6 eq {
6098                      /lignedeniveau table store
6099                      exit
6100                   } {
6101                      /lignedeniveau [
6102                         lignedeniveau aload pop
6103                         table 0 getp3d
6104                      ] store
6105                   } ifelse
6106                end
6107                } if
6108             } for
6109
6110             %% dessin de la ligne
6111             lignedeniveau length 4 ge {
6112                [lignedeniveau aload pop sortp3d] ligne3d
6113             } if
6114          grestore
6115       } for
6116    } if
6117
6118    end
6119 end
6120 } def
6121
6122 %% syntaxe : solid i dessinefacevisible
6123 /dessinefacevisible {
6124 8 dict begin
6125    /i exch def
6126    /solid exch def
6127    solid issolid not {
6128       (Error : mauvais type d argument dans dessinefacevisible) ==
6129       quit
6130    } if
6131    /F solid solidgetfaces def
6132    /S solid solidgetsommets def
6133
6134    /n F i get length def %% nb de sommets de la face
6135
6136    startest {
6137       s@lidlight {
6138          /coeff
6139             lightintensity
6140             solid i solidnormaleface normalize3d
6141             solid i solidcentreface lightsrc vecteur3d normalize3d
6142             scalprod3d mul
6143             0 max 1 min
6144          def
6145          /lightcolor where {
6146             pop
6147             /lacouleur lightcolor def
6148          } {
6149             /lacouleur [
6150                gsave
6151                   solid solidgetfcolors i get cvx exec currentrgbcolor
6152                grestore
6153             ] def
6154          } ifelse
6155          /fillstyle {
6156              lacouleur {coeff mul} apply setcolor Fill
6157          } def
6158          solidgrid not {
6159             lacouleur {coeff mul} apply setcolor
6160          } if
6161       } {
6162          n 2 eq {
6163             1 dict begin
6164                solidgridOff
6165                solid i affectecouleursolid_facei
6166             end
6167          } {
6168             solid i affectecouleursolid_facei
6169          } ifelse
6170       } ifelse
6171    } if
6172
6173    /face_a_dessiner [  %% face visible : F [i]
6174       0 1 n 1 sub {
6175          /j exch def
6176          solid j i solidgetsommetface
6177       } for
6178    ] def
6179    face_a_dessiner polygone3d
6180
6181    %% trace de la ligne de niveau
6182    solidintersectiontype 0 ge {
6183       0 1 solidintersectionplan length 1 sub {
6184          /k exch def
6185          /lignedeniveau [] def
6186          gsave
6187             k solidintersectionlinewidth length lt {
6188                solidintersectionlinewidth k get setlinewidth
6189             } {
6190                solidintersectionlinewidth 0 get setlinewidth
6191             } ifelse
6192             k solidintersectioncolor length lt {
6193                solidintersectioncolor k get cvx exec
6194             } {
6195                solidintersectioncolor 0 get cvx exec
6196             } ifelse
6197             0 1 n 1 sub {
6198                /j exch def
6199                face_a_dessiner j getp3d
6200                face_a_dessiner j 1 add n mod getp3d
6201                solidintersectionplan k get
6202                dup isarray {
6203                   segment_inter_plan
6204                } {
6205                   segment_inter_planz
6206                } ifelse {
6207                1 dict begin
6208                   /table exch def
6209                   /lignedeniveau [
6210                      lignedeniveau aload pop
6211                      table 0 getp3d
6212                      table length 4 ge {
6213                         table 1 getp3d
6214                      } if
6215                   ] store
6216                end
6217                } if
6218             } for
6219
6220             %% dessin de la ligne
6221             lignedeniveau length 4 ge {
6222                solid i solidisinface solidintersectiontype 0 eq and {
6223                   pointilles
6224                } if
6225                lignedeniveau ligne3d
6226             } if
6227          grestore
6228       } for
6229    } if
6230
6231 end
6232 } def
6233
6234 /drawsolid* {
6235 1 dict begin
6236    /startest {true} def
6237    drawsolid
6238 end
6239 } def
6240
6241 /peintrealgorithme false def
6242
6243 /drawsolid** {
6244 2 dict begin
6245    /aretescachees false def
6246    /peintrealgorithme true def
6247    drawsolid*
6248 end
6249 } def
6250
6251 %% syntaxe : solid array drawsolid
6252 %% array est en option, il indique les faces triees
6253 /drawsolid {
6254 8 dict begin
6255    dup issolid not {
6256       /ordre exch def
6257    } if
6258    /solid exch def
6259    solid issolid not {
6260       (Error : mauvais type d argument dans drawsolid) ==
6261       quit
6262    } if
6263    solid nullsolid not {
6264       solid solidgetfaces
6265       /F exch def
6266       solid solidgetsommets
6267       /S exch def
6268       /n S length 3 idiv def
6269
6270       currentdict /ordre known not {
6271          peintrealgorithme {
6272             %% tri des indices des faces par distance decroissante
6273             [
6274                0 1 F length 1 sub {
6275                   /i exch def
6276                   solid i solidcentreface
6277                   GetCamPos
6278                   distance3d
6279                } for
6280             ] doublequicksort pop reverse
6281          } {
6282             [
6283                0 1 F length 1 sub {
6284                } for
6285             ]
6286          } ifelse
6287          /ordre exch def
6288       } if
6289
6290       0 1 F length 1 sub {
6291          /k exch def
6292          /i ordre k get def
6293          gsave
6294             solid i solidfacevisible? {
6295                solid i dessinefacevisible
6296             } if
6297          grestore
6298       } for
6299       aretescachees {
6300          0 1 F length 1 sub {
6301             /k exch def
6302             /i ordre k get def
6303             gsave
6304                solid i solidfacevisible? not {
6305                   solid i dessinefacecachee
6306                } if
6307             grestore
6308          } for
6309       } if
6310
6311 %%       %% si on veut repasser les traits des faces visibles
6312 %%       0 1 F length 1 sub {
6313 %%          /k exch def
6314 %%          /i ordre k get def
6315 %%          gsave
6316 %%          1 dict begin
6317 %%             /startest false def
6318 %%             solid i solidfacevisible? {
6319 %%             solid i dessinefacevisible
6320 %%             } if
6321 %%          end
6322 %%          grestore
6323 %%       } for
6324    } if
6325 end
6326 } def
6327
6328 %%%%% ### segment_inter_planz ###
6329 %% syntaxe : A B k segment_inter_planz --> array true ou false
6330 /segment_inter_planz {
6331 4 dict begin
6332    /k exch def
6333    /B defpoint3d
6334    /A defpoint3d
6335    A /zA exch def pop pop
6336    B /zB exch def pop pop
6337    zA k sub zB k sub mul dup 0 gt {
6338       %% pas d intersection
6339       pop
6340       false
6341    } {
6342       0 eq {
6343          %% intersection en A ou en B
6344          [
6345             zA k eq {A} if
6346             zB k eq {B} if
6347          ] true
6348       } {
6349          %% intersection entre A et B
6350          [
6351             A B vecteur3d
6352             k zA sub zB zA sub div mulv3d
6353             A addv3d
6354          ] true
6355       } ifelse
6356    } ifelse
6357 end
6358 } def
6359
6360 %%%%% ### fin insertion ###
6361
6362 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
6363 %%%%                  plans affines                     %%%%
6364 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
6365
6366 %%%%% ### planaffine ###
6367 %% plan : origine, base, range, ngrid
6368 %% [0 0 0 [1 0 0 0 1 0] [-3 3 -2 2] [1. 1.] ]
6369
6370 /explan [0 0 0 [1 0 0 0 1 0 0 0 1] [-3 3 -2 2] [1. 1.] ] def
6371
6372 %% syntaxe : any isplan --> bool
6373 /isplan {
6374 1 dict begin
6375    /candidat exch def
6376    candidat isarray {
6377       candidat length 6 eq {
6378          candidat 3 get isarray {
6379             candidat 4 get isarray {
6380                candidat 5 get isarray
6381             } {
6382                false
6383             } ifelse
6384          } {
6385             false
6386          } ifelse
6387       } {
6388          false
6389       } ifelse
6390    } {
6391       false
6392    } ifelse
6393 end
6394 } def
6395
6396 /newplanaffine {
6397    [0 0 0 [1 0 0 0 1 0] [-3 3 -2 2] [1 1]]
6398 } def
6399
6400 /dupplan {
6401 4 dict begin
6402    /leplan exch def
6403    /result newplanaffine def
6404    result leplan plangetorigine planputorigine
6405    result leplan plangetbase planputbase
6406    result leplan plangetrange planputrange
6407    result leplan plangetngrid planputngrid
6408    result
6409 end
6410 } def
6411
6412 %% syntaxe : plantype getorigine --> x y z
6413 /plangetorigine {
6414 1 dict begin
6415    /plan exch def
6416    plan isplan not {
6417       (Erreur : mauvais type d argument dans plangetorigine) ==
6418       Error
6419    } if
6420    plan 0 get
6421    plan 1 get
6422    plan 2 get
6423 end
6424 } def
6425
6426 %% syntaxe : plantype getbase --> [u v]
6427 %% ou u, v et w vecteurs de R^3
6428 /plangetbase {
6429 1 dict begin
6430    /plan exch def
6431    plan isplan not {
6432       (Erreur : mauvais type d argument dans plangetbase) ==
6433       Error
6434    } if
6435    plan 3 get
6436 end
6437 } def
6438
6439 %% syntaxe : plantype getrange --> array
6440 %% ou array = [xmin xmax ymin ymax]
6441 /plangetrange {
6442 1 dict begin
6443    /plan exch def
6444    plan isplan not {
6445       (Erreur : mauvais type d argument dans plangetrange) ==
6446       Error
6447    } if
6448    plan 4 get
6449 end
6450 } def
6451
6452 %% syntaxe : plantype getngrid --> array
6453 %% ou array = [n1 n2]
6454 /plangetngrid {
6455 1 dict begin
6456    /plan exch def
6457    plan isplan not {
6458       (Erreur : mauvais type d argument dans plangetngrid) ==
6459       Error
6460    } if
6461    plan 5 get
6462 end
6463 } def
6464
6465 %% ===================
6466
6467 %% syntaxe : plantype x y z putorigine --> -
6468 /planputorigine {
6469 4 dict begin
6470    /z exch def
6471    /y exch def
6472    /x exch def
6473    /plan exch def
6474    plan isplan not {
6475       (Erreur : mauvais type d argument dans planputorigine) ==
6476       Error
6477    } if
6478    plan 0 x put
6479    plan 1 y put
6480    plan 2 z put
6481 end
6482 } def
6483
6484 %% syntaxe : plantype [u v w] putbase --> -
6485 %% ou u, v et w vecteurs de R^3
6486 /planputbase {
6487 2 dict begin
6488    /base exch def
6489    /plan exch def
6490    plan isplan not {
6491       (Erreur : mauvais type d argument dans planputbase) ==
6492       Error
6493    } if
6494    plan 3 base put
6495 end
6496 } def
6497
6498 %% syntaxe : plantype array putrange --> -
6499 %% ou array = [xmin xmax ymin ymax]
6500 /planputrange {
6501 2 dict begin
6502    /table exch def
6503    /plan exch def
6504    plan isplan not {
6505       (Erreur : mauvais type d argument dans planputrange) ==
6506       Error
6507    } if
6508    plan 4 table put
6509 end
6510 } def
6511
6512 %% syntaxe : plantype array putngrid --> -
6513 %% ou array = [n1 n2]
6514 /planputngrid {
6515 2 dict begin
6516    /table exch def
6517    /plan exch def
6518    plan isplan not {
6519       (Erreur : mauvais type d argument dans planputngrid) ==
6520       quit
6521    } if
6522    plan 5 table put
6523 end
6524 } def
6525
6526 %% -3 3 -2 2 1. 1. newgrille
6527 %% drawsolid
6528
6529 %orange
6530
6531 %% plan : origine, base, range, ngrid
6532
6533 %% syntaxe : plantype drawplanaffine --> -
6534 /drawplanaffine {
6535 5 dict begin
6536    /plan exch def
6537    plan plangetbase
6538    aload pop
6539    /imK defpoint3d
6540    /imJ defpoint3d
6541    /imI defpoint3d
6542    newpath
6543       plan plangetrange plan plangetngrid aload pop  quadrillagexOy_
6544       plan plangetorigine [imI imK] false planprojpath
6545    Stroke
6546 end
6547 } def
6548
6549
6550 %% %% syntaxe : [a b c d] (x0 y0 z0) alpha defeqplanaffine --> plantype
6551 %% %% plan defini par l equation ax+by+cz+d=0,
6552 %% %% rotation de alpha autour de la normale (alpha est optionnel)
6553 %% %% origine (x0, y0, z0). l origine est optionnelle
6554 %% /defeqplanaffine {
6555 %% 5 dict begin
6556 %%    dup isarray {
6557 %%       /alpha 0 def
6558 %%    } {
6559 %%       dup isstring {
6560 %%          /alpha 0 def
6561 %%       } {
6562 %%          /alpha exch def
6563 %%       } ifelse
6564 %%    } ifelse
6565 %%    dup isstring {
6566 %%       cvx /origine exch def
6567 %%    } if
6568 %%    /table exch def
6569 %%    table length 4 ne {
6570 %%       (Erreur : mauvais type d argument dans defeqplanaffine) ==
6571 %%       Error
6572 %%    } if
6573 %%    table 0 get /a exch def
6574 %%    table 1 get /b exch def
6575 %%    table 2 get /c exch def
6576 %%    table 3 get /d exch def
6577 %%    /resultat newplanaffine def
6578 %%    [a b c alpha] normalvect_to_orthobase
6579 %%    /imK defpoint3d
6580 %%    /imJ defpoint3d
6581 %%    /imI defpoint3d
6582 %%    resultat [imI imJ imK] planputbase
6583 %%    currentdict /origine known {
6584 %%       origine /z exch def /y exch def /x exch def
6585 %%       a x mul b y mul add c z mul add d add 0 ne {
6586 %%          (Erreur : mauvaise origine dans defeqplanaffine) ==
6587 %%          Error
6588 %%       } if
6589 %%       resultat origine planputorigine
6590 %%    } {
6591 %%       c 0 ne {
6592 %%          resultat 0 0 d neg c div planputorigine
6593 %%       } {
6594 %%          a 0 ne {
6595 %%             resultat d neg a div 0 0 planputorigine
6596 %%          } {
6597 %%             resultat 0 d neg b div 0 planputorigine
6598 %%          } ifelse
6599 %%       } ifelse
6600 %%    } ifelse
6601 %%    resultat
6602 %% end
6603 %% } def
6604
6605 %% /explan [0 0 0 [1 0 0 0 1 0 0 0 1] [-3 3 -2 2] [1 1] ] def
6606 %% explan drawplanaffine
6607 %% noir
6608 %% /explan [0 0 2 [1 0 0 0 1 0 0 0 1] [-3 3 -2 2] [1 .5] ] def
6609 %% explan drawplanaffine
6610
6611 %% orange
6612 %% [0 0 1 -2] defeqplanaffine
6613 %% drawplanaffine
6614 %% noir
6615 %% [0 0 1 0] defeqplanaffine
6616 %% drawplanaffine
6617 %% bleu
6618 %% [1 1 1 0] (1 -1 0) defeqplanaffine
6619 %% drawplanaffine
6620 %%
6621
6622 /dessinebase {
6623 4 dict begin
6624 gsave
6625    /V3 defpoint3d
6626    /V2 defpoint3d
6627    /V1 defpoint3d
6628    /M0 defpoint3d
6629    rouge
6630    V3 newvecteur
6631    {M0 translatepoint3d} solidtransform
6632    drawsolid**
6633    bleu
6634    V2 newvecteur
6635    {M0 translatepoint3d} solidtransform
6636    drawsolid**
6637    orange
6638    V1 newvecteur
6639    {M0 translatepoint3d} solidtransform
6640    drawsolid**
6641 grestore
6642 end
6643 } def
6644
6645 %% syntaxe : solid i solidface2eqplan --> [a b c d]
6646 %% equation cartesienne de la face d'indice i du solide solid
6647 /solidface2eqplan {
6648 8 dict begin
6649    /i exch def
6650    /solid exch def
6651    solid i solidnormaleface
6652    /c exch def
6653    /b exch def
6654    /a exch def
6655    solid 0 i solidgetsommetface
6656    /z exch def
6657    /y exch def
6658    /x exch def
6659    [a b c a x mul b y mul add c z mul add neg]
6660 end
6661 } def
6662
6663
6664 %% syntaxe : plantype newplan --> solid
6665 /newplan {
6666 5 dict begin
6667    /lepl@n exch def
6668    lepl@n plangetbase /@base exch def
6669    @base 0 getp3d /@U defpoint3d
6670    @base 1 getp3d /@V defpoint3d
6671    lepl@n plangetorigine /@M defpoint3d
6672    lepl@n plangetrange /@range exch def
6673    lepl@n plangetngrid /@ngrid exch def
6674    /@F {
6675    2 dict begin
6676       /@y exch def
6677       /@x exch def
6678       @U @x mulv3d
6679       @V @y mulv3d
6680       addv3d
6681       @M addv3d
6682    end
6683    } def
6684    @range aload pop @ngrid {@F} newsurfaceparametree
6685 end
6686 } def
6687
6688 %% syntaxe : M eqplan --> real
6689 %% image de M par la fonction definie par l equation eqplan
6690 /pointeqplan {
6691 8 dict begin
6692    /eqplan exch def
6693    /@z exch def
6694    /@y exch def
6695    /@x exch def
6696    /@a eqplan 0 get def
6697    /@b eqplan 1 get def
6698    /@c eqplan 2 get def
6699    /@d eqplan 3 get def
6700    @a @x mul @b @y mul add @c @z mul add @d add
6701 end
6702 } def
6703
6704 /plan2eq {
6705 6 dict begin
6706    /leplan exch def
6707    leplan plangetbase aload pop vectprod3d
6708    /c exch def
6709    /b exch def
6710    /a exch def
6711    leplan plangetorigine
6712    /z0 exch def
6713    /y0 exch def
6714    /x0 exch def
6715    [a b c a x0 mul b y0 mul add c z0 mul add neg]
6716 end
6717 } def
6718
6719 %% syntaxe : [a b c d] (x0 y0 z0) alpha defeqplanaffine --> plantype
6720 %% plan defini par l equation ax+by+cz+d=0,
6721 %% rotation de alpha autour de la normale (alpha est optionnel)
6722 %% origine (x0, y0, z0). l origine est optionnelle
6723 /eq2plan {
6724 5 dict begin
6725    dup isarray {
6726       /alpha 0 def
6727    } {
6728       dup isstring {
6729          /alpha 0 def
6730       } {
6731          /alpha exch def
6732       } ifelse
6733    } ifelse
6734    dup isstring {
6735       cvx /origine exch def
6736    } if
6737    /table exch def
6738    table length 4 ne {
6739       (Erreur : mauvais type d argument dans eq2plan) ==
6740       quit
6741    } if
6742    table 0 get /a exch def
6743    table 1 get /b exch def
6744    table 2 get /c exch def
6745    table 3 get /d exch def
6746    /resultat newplanaffine def
6747    [a b c alpha] normalvect_to_orthobase
6748    /imK defpoint3d
6749    /imJ defpoint3d
6750    /imI defpoint3d
6751    resultat [imI imJ] planputbase
6752    currentdict /origine known {
6753       origine /z exch def /y exch def /x exch def
6754       a x mul b y mul add c z mul add d add 0 ne {
6755          (Erreur : mauvaise origine dans eq2plan) ==
6756          quit
6757       } if
6758       resultat origine planputorigine
6759    } {
6760       c 0 ne {
6761          resultat 0 0 d neg c div planputorigine
6762       } {
6763          a 0 ne {
6764             resultat d neg a div 0 0 planputorigine
6765          } {
6766             b 0 ne {
6767                resultat 0 d neg b div 0 planputorigine
6768             } {
6769                (Error dans eq2plan : (a,b,c) = (0,0,0)) ==
6770             } ifelse
6771          } ifelse
6772       } ifelse
6773    } ifelse
6774    resultat
6775 end
6776 } def
6777
6778 /points2eqplan {
6779 10 dict begin
6780    /C defpoint3d
6781    /B defpoint3d
6782    /A defpoint3d
6783    A B vecteur3d
6784    A C vecteur3d
6785    vectprod3d
6786    normalize3d
6787    /c exch def
6788    /b exch def
6789    /a exch def
6790    A
6791    /zA exch def
6792    /yA exch def
6793    /xA exch def
6794    [a b c a xA mul b yA mul add c zA mul add neg]
6795 end
6796 } def
6797
6798 %% /monplan
6799 %% %[0 0 -2 [1 0 0 0 1 0 0 0 1] [-3 3 -2 2] [1. 1.]]
6800 %% [0 0 1 1] 30 eq2plan
6801 %% def
6802 %%
6803 %% [0 0 1 -2] eq2plan newplan
6804 %% dup (blanc) outputcolors
6805 %% monplan newplan
6806 %% dup (blanc) outputcolors
6807 %% solidfuz
6808 %% drawsolid**
6809 %% monplan plangetorigine
6810 %% monplan plangetbase aload pop dessinebase
6811
6812 %% syntaxe : x0 y0 z0 [normalvect] norm2plan
6813 /norm2plan {
6814 9 dict begin
6815    normalvect_to_orthobase
6816    /imK defpoint3d
6817    /imJ defpoint3d
6818    /imI defpoint3d
6819    imK
6820    /c exch def
6821    /b exch def
6822    /a exch def
6823    /z0 exch def
6824    /y0 exch def
6825    /x0 exch def
6826    [a b c a x0 mul b y0 mul add c z0 mul add neg] eq2plan
6827    dup x0 y0 z0 planputorigine
6828    dup [imI imJ] planputbase
6829 end
6830 } def
6831
6832 %% syntaxe : plantype planxmarks
6833 /planxmarks {
6834 5 dict begin
6835    dup isbool {
6836       /mybool exch def
6837    } {
6838       /mybool true def
6839    } ifelse
6840    /leplan exch def
6841    leplan plangetrange aload pop
6842    /ymax exch def
6843    /ymin exch def
6844    /xmax exch def
6845    /xmin exch def
6846    newpath
6847       xmin truncate cvi 0 smoveto
6848       xmax truncate cvi 0 slineto
6849       leplan mybool projpath
6850    Stroke
6851    xmin truncate cvi xmkstep xmax truncate cvi {
6852       dup 0 ne {
6853          /x exch def
6854          x
6855          x x truncate eq {
6856             cvi
6857          } if
6858          dup chaine cvs exch 0 leplan mybool dctextp3d
6859          newpath
6860             x 0 smoveto
6861             0 2.5 rmoveto
6862             0 -5 rlineto
6863             leplan mybool projpath
6864          Stroke
6865       } {
6866          pop (0) 0 0 leplan mybool dltextp3d
6867       } ifelse
6868    } for
6869 end
6870 } def
6871
6872 %% syntaxe : plantype planymarks
6873 /planymarks {
6874 5 dict begin
6875    dup isbool {
6876       /mybool exch def
6877    } {
6878       /mybool true def
6879    } ifelse
6880    /leplan exch def
6881    leplan plangetrange aload pop
6882    /ymax exch def
6883    /ymin exch def
6884    /xmax exch def
6885    /xmin exch def
6886    newpath
6887       0 ymin truncate cvi smoveto
6888       0 ymax truncate cvi slineto
6889       leplan mybool projpath
6890    Stroke
6891    ymin truncate cvi ymkstep ymax truncate cvi {
6892       dup 0 ne {
6893          /y exch def
6894          y
6895          y y truncate eq {
6896              cvi
6897          } if
6898          dup chaine cvs exch 0 exch leplan mybool cltextp3d
6899          newpath
6900             0 y smoveto
6901             2.5 0 rmoveto
6902             -5 0 rlineto
6903             leplan mybool projpath
6904          Stroke
6905       } {
6906          pop (0) 0 0 leplan mybool dltextp3d
6907       } ifelse
6908    } for
6909 end
6910 } def
6911
6912 %% syntaxe : plantype planmarks
6913 /planmarks {
6914 1 dict begin
6915     dup isbool {
6916       /mybool exch def
6917    } {
6918       /mybool true def
6919    } ifelse
6920    dup mybool planxmarks mybool planymarks
6921 end
6922 } def
6923
6924 %% bleu
6925 %% [-3 3 -2 2] quadrillagexOy_
6926 %% Stroke
6927 %% noir
6928
6929 %% syntaxe : [xmin xmax ymin ymax] dx dy quadrillagexOy_
6930 /quadrillagexOy_ {
6931 4 dict begin
6932    dup isarray {
6933       /dx 1 def
6934       /dy 1 def
6935    } {
6936       /dy exch def
6937       dup isarray {
6938          /dx dy def
6939       } {
6940          /dx exch def
6941       } ifelse
6942    } ifelse
6943    /table exch def
6944    table 0 get /xmin exch def
6945    table 1 get /xmax exch def
6946    table 2 get /ymin exch def
6947    table 3 get /ymax exch def
6948    ymin dy ymax {
6949       /y exch def
6950       xmin y smoveto
6951       xmax y slineto
6952    } for
6953    xmin dx xmax {
6954       /x exch def
6955       x ymin smoveto
6956       x ymax slineto
6957    } for
6958 end
6959 } def
6960
6961 %% syntaxe : plan [ngrid] planquadrillage
6962 /planquadrillage {
6963 4 dict begin
6964    dup isbool {
6965       /mybool exch def
6966    } {
6967       /mybool true def
6968    } ifelse
6969    dup isplan {
6970       /ngrid [1 1] def
6971    } {
6972       /ngrid exch def
6973    } ifelse
6974    /leplan exch def
6975    /dx ngrid 0 get def
6976    /dy ngrid 1 get def
6977    /table leplan plangetrange def
6978    table 0 get cvi truncate /xmin exch def
6979    table 1 get cvi truncate /xmax exch def
6980    table 2 get cvi truncate /ymin exch def
6981    table 3 get cvi truncate /ymax exch def
6982    newpath
6983       ymin dy ymax {
6984          /y exch def
6985          xmin y smoveto
6986          xmax y slineto
6987       } for
6988       xmin dx xmax {
6989          /x exch def
6990          x ymin smoveto
6991          x ymax slineto
6992       } for
6993       leplan mybool projpath
6994    Stroke
6995 end
6996 } def
6997
6998 %% syntaxe : plantype str1 str2 planshowbase -> -
6999 %% syntaxe : plantype str2 planshowbase -> -
7000 %% syntaxe : plantype planshowbase -> -
7001 /planshowbase {
7002 3 dict begin
7003    dup isbool {
7004       /mybool exch def
7005    } {
7006       /mybool true def
7007    } ifelse
7008    dup isstring {
7009       /couleur2 exch def
7010       dup isstring {
7011          /couleur1 exch def
7012       } {
7013          /couleur1 (rouge) def
7014       } ifelse
7015    } {
7016       /couleur1 (rouge) def
7017       /couleur2 (vert) def
7018    } ifelse
7019    mybool bprojscene
7020       couleur1 cvx exec
7021       newpath
7022          0 0 smoveto
7023          1 0 slineto
7024       Stroke
7025       0 0 1 0 oldarrow
7026       couleur2 cvx exec
7027       newpath
7028          0 0 smoveto
7029          0 1 slineto
7030       Stroke
7031       0 0 0 1 oldarrow
7032    eprojscene
7033 end
7034 } def
7035
7036 %% syntaxe : plantype str1 str2 str3 planshowbase3d -> -
7037 %% syntaxe : plantype str2 str3 planshowbase3d -> -
7038 %% syntaxe : plantype str3 planshowbase3d -> -
7039 %% syntaxe : plantype planshowbase3d -> -
7040 %% syntaxe : plantype str1 str2 str3 array planshowbase3d -> -
7041 %% syntaxe : plantype str2 str3 array planshowbase3d -> -
7042 %% syntaxe : plantype str3 array planshowbase3d -> -
7043 %% syntaxe : plantype array planshowbase3d -> -
7044 /planshowbase3d {
7045 7 dict begin
7046    dup isbool {
7047       /mybool exch def
7048    } {
7049       /mybool true def
7050    } ifelse
7051    dup dup isarray exch isplan not and {
7052       /table exch def
7053    } {
7054       /table {} def
7055    } ifelse
7056    dup isstring {
7057       /couleur3 exch def
7058       dup isstring {
7059          /couleur2 exch def
7060          dup isstring {
7061             /couleur1 exch def
7062          } {
7063             /couleur1 (rouge) def
7064          } ifelse
7065       } {
7066          /couleur2 (vert) def
7067          /couleur1 (rouge) def
7068       } ifelse
7069    } {
7070       /couleur1 (rouge) def
7071       /couleur2 (vert) def
7072       /couleur3 (bleu) def
7073    } ifelse
7074    /plan exch def
7075    plan couleur1 couleur2 mybool planshowbase
7076    plan plangetorigine /I defpoint3d
7077    plan plangetbase
7078    dup 0 getp3d /u defpoint3d
7079    1 getp3d /v defpoint3d
7080    u v vectprod3d table newvecteur
7081    {I addv3d} solidtransform
7082    dup couleur3 solidputcolors
7083    solidgridOff
7084    drawsolid**
7085 end
7086 } def
7087
7088 %% syntaxe : plantype x y z plantranslate --> -
7089 /plantranslate {
7090 4 dict begin
7091    /M defpoint3d
7092    /plan exch def
7093    plan isplan not {
7094       (Erreur : mauvais type d argument dans plantranslate) ==
7095       quit
7096    } if
7097    plan plan plangetorigine M addv3d planputorigine
7098 end
7099 } def
7100
7101 % syntaxe : alpha_x alpha_y alpha_z rotateOpplan --> -
7102 /rotateOplan {
7103 4 dict begin
7104    /Rxyz defpoint3d
7105    /plan exch def
7106    plan isplan not {
7107       (Erreur : mauvais type d argument dans rotateOplan) ==
7108       quit
7109    } if
7110    plan plan plangetorigine Rxyz rotateOpoint3d planputorigine
7111
7112    plan plangetbase 0 getp3d /U defpoint3d
7113    plan plangetbase 1 getp3d /V defpoint3d
7114    plan [
7115       U Rxyz rotateOpoint3d
7116       V Rxyz rotateOpoint3d
7117    ] planputbase
7118 end
7119 } def
7120
7121 %% syntaxe : plantype phi rotateplan --> -
7122 /rotateplan {
7123 5 dict begin
7124    /phi exch def
7125    /leplan exch def
7126    leplan plangetbase 0 getp3d /U defpoint3d
7127    leplan plangetbase 1 getp3d /V defpoint3d
7128    U phi cos mulv3d
7129    V phi sin mulv3d addv3d /U0 defpoint3d
7130    U phi sin neg mulv3d
7131    V phi cos mulv3d addv3d /V0 defpoint3d
7132    leplan [U0 V0] planputbase
7133 end
7134 } def
7135
7136 %% syntaxe : solid i solidface2plan --> plantype
7137 %% syntaxe : solid i I solidface2plan --> plantype
7138 /solidface2plan {
7139 5 dict begin
7140    2 copy pop issolid {
7141       /i exch def
7142       /solid exch def
7143       solid i solidcentreface /I defpoint3d
7144    } {
7145       /I defpoint3d
7146       /i exch def
7147       /solid exch def
7148    } ifelse
7149    /result newplanaffine def
7150    solid i solidcentreface /G defpoint3d
7151    solid i solidnormaleface /K defpoint3d
7152    solid 0 i solidgetsommetface
7153    solid 1 i solidgetsommetface
7154    milieu3d /A defpoint3d
7155    G A vecteur3d normalize3d /U defpoint3d
7156    K U vectprod3d /V defpoint3d
7157    result [U V] planputbase
7158    result I planputorigine
7159    result
7160 end
7161 } def
7162
7163 %%%%% ### fin insertion ###
7164 %% syntaxe : x y plantype pointplan --> X Y Z
7165 /pointplan {
7166 5 dict begin
7167    /leplan exch def
7168    /y exch def
7169    /x exch def
7170    leplan plangetbase 0 getp3d /U defpoint3d
7171    leplan plangetbase 1 getp3d /V defpoint3d
7172    U x mulv3d V y mulv3d addv3d
7173 end
7174 } def
7175
7176 %%%%% ### fin insertion ###
7177
7178
7179 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7180 %%%%     operations sur des solides particuliers        %%%%
7181 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7182
7183 /piedist {
7184 4 dict begin
7185    /mypie exch def
7186    mypie 0 solidgetface length /n exch def
7187    mypie n 2 idiv solidgetsommet /A defpoint3d
7188    mypie n 2 idiv 1 add solidgetsommet /B defpoint3d
7189    A B milieu3d GetCamPos distance3d
7190 end
7191 } def
7192
7193 /sortpieset {
7194 5 dict begin
7195    dup issolid {
7196       ]
7197    } if
7198    /table exch def
7199    [
7200       0 1 table length 1 sub {
7201          /i exch def
7202          table i get piedist
7203       } for
7204    ]
7205    doublequicksort pop reverse
7206    /result exch def
7207    [
7208       0 1 result length 1 sub {
7209          /i exch def
7210          table result i get get
7211       } for
7212    ]
7213 end
7214 } def
7215
7216 /drawpieset {
7217 1 dict begin
7218    /startest true def
7219    sortpieset dup {drawsolid**} apply {0 dessinefacevisible} apply
7220 end
7221 } def
7222
7223 %%%%% ### solidchanfreine ###
7224 %% syntaxe : solid coeff solidchanfreine --> solid
7225 /solidchanfreine {
7226 10 dict begin
7227    /coeff exch def
7228    /solid exch def
7229    /result newsolid def
7230    solid issolid not {
7231       (Erreur : mauvais type d argument dans solidchanfreine) ==
7232       quit
7233    } if
7234    /n solid solidnombresommets def
7235    /nf solid solidnombrefaces def
7236
7237    %% ajout des faces reduites
7238    0 1 nf 1 sub {
7239       /i exch def
7240       /Fsommets solid i solidgetsommetsface def
7241       /Findex solid i solidgetface def
7242       /ns Fsommets length 3 idiv def
7243       /couleurfaceorigine solid i solidgetfcolor def
7244       Fsommets isobarycentre3d /G defpoint3d
7245       %% on ajoute les nouveaux sommets
7246       /Sindex [] def
7247       0 1 ns 1 sub {
7248          /j exch def
7249          /Sindex [ Sindex aload pop
7250             Fsommets j getp3d /M defpoint3d
7251             result M G coeff hompoint3d solidaddsommet
7252          ] store
7253       } for
7254       %% Sindex contient les indices des nouveaux sommets
7255       result Sindex couleurfaceorigine solidaddface
7256    } for
7257
7258    %% ajout des faces rectangulaires entre faces d'origines adjacentes
7259    %% pour chaque face de depart
7260    0 1 nf 2 sub {
7261       /i exch def
7262       /F solid i solidgetface def
7263       /couleurfaceorigine solid i solidgetfcolor def
7264       /Fres result i solidgetface def
7265       %% pour chaque arete de la face
7266       0 1 F length 1 sub {
7267          /j exch def
7268          /trouve false def
7269          /indice1 F j get def
7270          /indice2 F j 1 add F length mod get def
7271          /a1 j def
7272          /a2 j 1  add F length mod def
7273          %% on regarde toutes les autres faces
7274          i 1 add 1 nf 1 sub {
7275             /k exch def
7276             /Ftest solid k solidgetface def
7277             indice1 Ftest in {pop true} {false} ifelse
7278             indice2 Ftest in {pop true} {false} ifelse
7279             and {
7280                /indiceFadj k def
7281                indice1 Ftest in pop /k1 exch def
7282                indice2 Ftest in pop /k2 exch def
7283                /trouve true def
7284             exit
7285             } if
7286          } for
7287          trouve {
7288             /Fadj solid indiceFadj solidgetface def
7289             result [
7290                Fres a1 get
7291                result indiceFadj solidgetface k1 get
7292                result indiceFadj solidgetface k2 get
7293                Fres a2 get
7294             ] couleurfaceorigine solidaddface
7295          } if
7296       } for
7297    } for
7298
7299    %% pour chaque face
7300    0 1 nf 2 sub {
7301       /i exch def
7302       /F solid i solidgetface def
7303       /couleurfaceorigine solid i solidgetfcolor def
7304       %% et pour chaque sommet de cette face
7305       0 1 F length 1 sub {
7306          /j exch def
7307          /k F j get def
7308          solid k solidfacesadjsommet /adj exch def
7309          %% adj est le tableau des indices des faces adjacentes
7310          %% au sommet d'indice k
7311          %% rque : toutes les faces d'indice strict inferieur a i
7312          %% sont deja traitees
7313          %% Pour chaque face adjacente, on repere l'indice du sommet concerne dans
7314          %% la face
7315          adj min i lt not {
7316             /indadj [] def
7317             0 1 adj length 1 sub {
7318                /m exch def
7319                k solid adj m get solidgetface in {
7320                   /ok exch def
7321                   /indadj [indadj aload pop ok] store
7322                } if
7323             } for
7324
7325             /aajouter [
7326                0 1 adj length 1 sub {
7327                   /m exch def
7328                   result adj m get solidgetface indadj m get get
7329                } for
7330             ] def
7331
7332             %% la table des sommets
7333             [0 1 aajouter length 1 sub {
7334                /m exch def
7335                result aajouter m get solidgetsommet
7336             } for]
7337             solid k solidgetsommet %% le point indiquant la direction de la normale
7338             ordonnepoints3d
7339             /indicestries exch def
7340
7341             result [
7342                0 1 indicestries length 1 sub {
7343                   /m exch def
7344                   aajouter indicestries m get get
7345                } for
7346             ] couleurfaceorigine solidaddface
7347          } if
7348       } for
7349    } for
7350
7351    result
7352 end
7353 } def
7354
7355 %%%%% ### solidplansection ###
7356 %% syntaxe : M eqplan --> real
7357 %% image de M par la fonction definie par l equation eqplan
7358 /pointeqplan {
7359 8 dict begin
7360    /@qplan exch def
7361    /@z exch def
7362    /@y exch def
7363    /@x exch def
7364    /@a @qplan 0 get def
7365    /@b @qplan 1 get def
7366    /@c @qplan 2 get def
7367    /@d @qplan 3 get def
7368    @a @x mul @b @y mul add @c @z mul add @d add
7369 end
7370 } def
7371
7372 %% syntaxe : A B eqplan segment_inter_plan --> array true ou false
7373 %% array contient 1 point M si [AB] inter plan = {M}
7374 %% array contient les 2 points A et B si [AB] inter plan = [AB]
7375 /segment_inter_plan {
7376 4 dict begin
7377    dup isplan {plan2eq} if
7378    /plan exch def
7379    plan aload pop
7380    /d exch def
7381    /c exch def
7382    /b exch def
7383    /a exch def
7384    /B defpoint3d
7385    /A defpoint3d
7386    A
7387    /zA exch def
7388    /yA exch def
7389    /xA exch def
7390    B
7391    /zB exch def
7392    /yB exch def
7393    /xB exch def
7394    /imA a xA mul b yA mul add c zA mul add d add def
7395    /imB a xB mul b yB mul add c zB mul add d add def
7396    imA imB mul dup 0 gt {
7397       %% pas d intersection
7398       pop
7399       false
7400    } {
7401       0 eq {
7402          %% intersection en A ou en B
7403          [
7404             imA 0 eq {A} if
7405             imB 0 eq {B} if
7406          ] true
7407       } {
7408          %% intersection entre A et B
7409          /k
7410             imA neg
7411             xB xA sub a mul
7412             yB yA sub b mul add
7413             zB zA sub c mul add
7414             dup 0 eq {
7415                (Error dans segment_inter_plan) ==
7416                quit
7417             } if
7418             div
7419          def
7420          [
7421             A B vecteur3d
7422             k mulv3d
7423             A addv3d
7424          ] true
7425       } ifelse
7426    } ifelse
7427 end
7428 } def
7429
7430 %% syntaxe : solid i solidface2eqplan --> [a b c d]
7431 %% equation cartesienne de la face d'indice i du solide solid
7432 /solidface2eqplan {
7433 8 dict begin
7434    /i exch def
7435    /solid exch def
7436    solid i solidnormaleface
7437    /c exch def
7438    /b exch def
7439    /a exch def
7440    solid 0 i solidgetsommetface
7441    /z exch def
7442    /y exch def
7443    /x exch def
7444    [a b c a x mul b y mul add c z mul add neg]
7445 end
7446 } def
7447
7448 %% syntaxe : array1 arrayrmdouble --> array2
7449 %% remplace 2 elts identiques consecutifs par 1 elt
7450 /arrayrmdouble {
7451 5 dict begin
7452    /table exch def
7453    /result [table 0 get] def
7454    /j 0 def
7455    1 1 table length 1 sub {
7456       /i exch def
7457       table i get
7458       result j get
7459       eq not {
7460          /result [result aload pop table i get] store
7461          /j j 1 add store
7462       } if
7463    } for
7464    result
7465 end
7466 } def
7467
7468 %% syntaxe : solid eqplan/plantype solidplansection --> solid2
7469 /solidplansection {
7470 10 dict begin
7471    dup isbool {
7472       /tr@nsmit exch def
7473    } {
7474       /tr@nsmit false def
7475    } ifelse
7476    dup isplan {
7477       plan2eqplan
7478       /eqplan exch def
7479    } {
7480       /eqplan exch def
7481    } ifelse
7482    dupsolid /result exch def
7483    /solid exch def
7484    /aenlever [] def
7485    /indnouveauxsommets [] def
7486    /nouvellesaretes [] def
7487
7488    %% pour chaque face d'indice i
7489    0 1 solid solidnombrefaces 1 sub {
7490       /i exch def
7491       /lacouleur solid i solidgetfcolor def
7492       /F solid i solidgetface def %% table des indices des sommets
7493       /n F length def %% nb d'aretes
7494       /k1 -1 def
7495       /k2 -1 def
7496       /k3 -1 def
7497       /k4 -1 def
7498       /k3a -3 def
7499       /k4a -3 def
7500       %% pour chaque arete [AB]
7501       0 1 n 1 sub {
7502          /j exch def
7503          %% arete testee : [j, j+1 mod n] (indices relatifs a la face i)
7504          solid j i solidgetsommetface /A defpoint3d
7505          solid j 1 add n mod i solidgetsommetface /B defpoint3d
7506          %% y a-t-il intersection
7507          A B eqplan segment_inter_plan {
7508             %% il y a intersection
7509             dup length 6 eq {
7510                %% l'intersection, c'est [AB]
7511                /k1 -1 def
7512                /k2 -1 def
7513                /k3 -1 def
7514                /k4 -1 def
7515                /k3a -1 def
7516                /k4a -1 def
7517                dup 0 getp3d /A defpoint3d
7518                1 getp3d /B defpoint3d
7519                result A solidaddsommet /a1 exch def
7520                result B solidaddsommet /a2 exch def
7521                /indnouveauxsommets [
7522                   indnouveauxsommets aload pop a1 a2
7523                ] store
7524                /nouvellesaretes [
7525                   [a1 a2]
7526                   nouvellesaretes aload pop
7527                ] store
7528                exit %% c est deja scinde
7529             } if
7530             %% il y a intersection <> [AB]
7531             k1 0 lt {
7532             %% 1ere intersection de la face
7533                /k1 j def %% sommet precedent intersection 1
7534                result exch aload pop solidaddsommet
7535                /k1a exch def %% sommet intersection 1
7536             } {
7537                k2 0 lt {
7538                %% 2eme intersection de la face
7539                   /k2 j def %% sommet precedent intersection 2
7540                   result exch aload pop solidaddsommet
7541                   /k2a exch def %% sommet intersection 2
7542                } {
7543                   k3 0 lt {
7544                   %% 3eme intersection de la face
7545                      /k3 j def %% sommet precedent intersection 3
7546                      result exch aload pop solidaddsommet
7547                      /k3a exch def %% sommet intersection 3
7548                   } {
7549                   %% 4eme intersection de la face
7550                      /k4 j def %% sommet precedent intersection 4
7551                      result exch aload pop solidaddsommet
7552                      /k4a exch def %% sommet intersection 4
7553                   } ifelse
7554                } ifelse
7555             } ifelse
7556          } if
7557       } for
7558
7559       %% y a-t-il eu une coupe ?
7560       %% si oui, il faut scinder la face d'indice i en cours
7561       k1 0 ge {
7562 %% (coupe) ==
7563 %% (n) == n ==
7564 %% k1 == k2 == k3 == k4 ==
7565 %% (a) ==
7566 %% k1a == k2a == k3a == k4a ==
7567          k1a k2a eq k3 0 lt and {
7568             %% 1 pt d'intersection
7569          } {
7570             %% il y a coupe, on cherche a eliminer les
7571             %% doublons dans {k1a, k2a, k3a, k4a}
7572             k1a k2a eq k3 0 ge and {
7573                %% 2 pts d'intersection
7574                /k2a k3a def
7575                /k2 k3 def
7576             } if
7577             k1a k3a eq k4 0 ge and {
7578                %% 2 pts d'intersection
7579                /k2a k4a def
7580                /k2 k4 def
7581             } if
7582             /nouvellesaretes [
7583                [k1a k2a]
7584                nouvellesaretes aload pop
7585             ] store
7586             [
7587                k1a F k1 1 add n mod get ne {
7588                   k1a
7589                } if
7590                k1 1 add n mod 1 k2 {F exch get} for
7591                k2a F k2 get ne {
7592                   k2a
7593                } if
7594             ]
7595             result exch lacouleur solidaddface
7596             /indnouveauxsommets [indnouveauxsommets aload pop k1a k2a] store
7597             [
7598                k2a F k2 1 add n mod get ne {
7599                   k2a
7600                } if
7601                k2 1 add n ne {
7602                   k2 1 add n mod 1 n 1 sub {F exch get} for
7603                } if
7604                0 1 k1 {F exch get} for
7605                k1a F k1 get ne {
7606                   k1a
7607                } if
7608             ]
7609             result exch lacouleur solidaddface
7610             /aenlever [aenlever aload pop i] store
7611          } ifelse
7612       } if
7613    } for
7614    result aenlever solidrmfaces
7615
7616    nouvellesaretes separe_composantes
7617    /composantes exch def
7618
7619    %% pour chacune des composantes
7620    0 1 composantes length 1 sub {
7621       %% on oriente et on ajoute la face
7622       /icomp exch def
7623       %indnouveauxsommets bubblesort arrayrmdouble
7624       /indnouveauxsommets composantes icomp get def
7625       %% maintenant, on ajoute la face de plan de coupe
7626       /nouveauxsommets [
7627          0 1 indnouveauxsommets length 1 sub {
7628             /i exch def
7629             result indnouveauxsommets i get solidgetsommet
7630          } for
7631       ] def
7632
7633       0 0 0 eqplan pointeqplan 0 eq {
7634          /ptref {0 1 1} def
7635       } {
7636          /ptref {0 0 0} def
7637       } ifelse
7638
7639       %% restera a traiter le cas limite ou la nouvelle face existe deja
7640       %% tester si max(indicestries) < nb sommets avant section
7641       nouveauxsommets ptref ordonnepoints3d
7642       /indicestries exch def
7643       /nvelleface [
7644          0 1 indicestries length 1 sub {
7645             /m exch def
7646             indnouveauxsommets indicestries m get get
7647          } for
7648       ] def
7649       /F result solidgetfaces def
7650       /FC result solidgetfcolors def
7651       /IO result solidgetinouttable def
7652       /n1 IO 1 get def
7653       IO 1 n1 1 add put
7654       result IO solidputinouttable
7655       result [nvelleface F aload pop] solidputfaces
7656       result [lacouleur FC aload pop] solidputfcolors
7657    } for
7658    result
7659    tr@nsmit {
7660       composantes length
7661    } if
7662 end
7663 } def
7664
7665 %% syntaxe : elt array compteoccurences
7666 %% ou array est un tableau du type [ [a1 a2] [b1 b2] [c1 c2] ... ]
7667 /compteoccurences {
7668 5 dict begin
7669    /table exch def
7670    /elt exch def
7671    /n 0 def
7672    0 1 table length 1 sub {
7673       /i exch def
7674       elt table i get in {
7675          pop
7676          /n n 1 add store
7677       } if
7678    } for
7679    n
7680 end
7681 } def
7682
7683 /separe_composantes {
7684 10 dict begin
7685    /result [] def %% les composantes deja faites
7686    /table exch def %% ce qui reste a faire
7687
7688 %   (recu) == table {==} apply
7689    {
7690       /ext1 table 0 get 1 get def
7691       /ext0 table 0 get 0 get def
7692       /composante [] def
7693
7694       { %% maintenant on suit les extremites et on epluche une composante
7695          /change false def
7696          /aenlever [] def
7697          0 1 table length 1 sub {
7698             /i exch def
7699             ext1 table i get In
7700             ext0 table i get In or {
7701                /aenlever [aenlever aload pop i] store
7702                /change true store
7703                %% l'arete i contient l'extremite ext0 ou ext1
7704                ext0 table i get in {
7705                   %% index = 0 ou 1
7706                   neg 1 add table i get exch get
7707                   /ext0 exch store
7708                   ext0 composante In not {
7709                      /composante [composante aload pop ext0] store
7710                   } if
7711                   %% on verifie que ext0 est legitime
7712                   ext0 table compteoccurences 2 gt {
7713                      /ext0 -1 store
7714                   } if
7715                } if
7716                ext1 table i get in {
7717                   %% index = 0 ou 1
7718                   neg 1 add table i get exch get
7719                   /ext1 exch store
7720                   ext1 composante In not {
7721                      /composante [composante aload pop ext1] store
7722                   } if
7723                   %% on verifie que ext1 est legitime
7724                   ext1 table compteoccurences 2 gt {
7725                      /ext1 -1 store
7726                   } if
7727                } if
7728             } if
7729          } for
7730          %% il faut reconstruire table
7731          /table [
7732             0 1 table length 1 sub {
7733                /i exch def
7734                i aenlever in {
7735                   pop
7736                } {
7737                   table i get
7738                } ifelse
7739             } for
7740          ] store
7741          change not {exit} if
7742       } loop
7743       %% on vient de finir une composante
7744       /result [result aload pop composante] store
7745       %% (nouvelle comp) == composante {==} apply
7746       table length 0 eq {exit} if
7747    } loop
7748    result
7749 %   (renvoie) == result {==} apply
7750 end
7751 } def
7752
7753 /solideqplansepare {solidplansepare} def
7754
7755 %% syntaxe : solid eqplan/plantype solidplansepare --> solid1 solid2
7756 /solidplansepare {
7757 10 dict begin
7758    dup isplan {
7759       plan2eq
7760       /eqplan exch def
7761    } {
7762       /eqplan exch def
7763    } ifelse
7764    eqplan true solidplansection
7765    /nbcomposantes exch def
7766    /solid exch def
7767    /n solid solidnombrefaces def
7768
7769    /F [] def
7770    /FC [] def
7771    %% on retire les faces de coupe
7772    0 1 nbcomposantes 1 sub {
7773       /i exch def
7774       /F [F aload pop solid i solidgetface] store
7775       /FC [FC aload pop solid i solidgetfcolor] store
7776    } for
7777    solid [0 1 nbcomposantes 1 sub {} for] solidrmfaces
7778    /n n nbcomposantes sub store
7779
7780    %% on separe les autres faces en 2 parties
7781    /lesneg [] def %% indices des faces "positives"
7782    /lespos [] def %% indices des faces negatives"
7783    0 1 n 1 sub {
7784       /i exch def
7785       solid i solidcentreface /G defpoint3d
7786       G eqplan pointeqplan dup 0 gt {
7787          pop
7788          /lespos [lespos aload pop i] store
7789       } {
7790          0 lt {
7791             /lesneg [lesneg aload pop i] store
7792          } {
7793 %           /lesneg [lesneg aload pop i] store
7794 %           /lespos [lespos aload pop i] store
7795          } ifelse
7796       } ifelse
7797    } for
7798    solid
7799    dupsolid dup lesneg solidrmfaces
7800    /result1 exch def
7801    dupsolid dup lespos solidrmfaces
7802    /result2 exch def
7803    pop
7804
7805    0 1 nbcomposantes 1 sub {
7806       /i exch def
7807       /facecoupe F i get def
7808       /couleurfacecoupe FC i get def
7809       /lesfaces1 result1 solidgetfaces def
7810       /lescouleurs1 result1 solidgetfcolors def
7811       /IO1 result1 solidgetinouttable def
7812       /lesfaces2 result2 solidgetfaces def
7813       /lescouleurs2 result2 solidgetfcolors def
7814       /IO2 result2 solidgetinouttable def
7815       %% on rajoute maintenant la face du plan de coupe
7816 %      result1 facecoupe couleurfacecoupe solidaddface
7817       result1 [facecoupe lesfaces1 aload pop] solidputfaces
7818       result1 [couleurfacecoupe lescouleurs1 aload pop] solidputfcolors
7819       result1 IO1 dup dup 1 get 1 add 1 exch put solidputinouttable
7820       %% et on verifie l'orientation
7821 %      result1 dup solidnombrefaces 1 sub solidnormaleface
7822 %      result1 dup solidnombrefaces 1 sub solidcentreface addv3d
7823       result1 0 solidnormaleface
7824       result1 0 solidcentreface addv3d
7825       eqplan pointeqplan 0 gt {
7826          %% l'orientation est mauvaise
7827          result1 0 solidrmface
7828          result2 [facecoupe lesfaces2 aload pop] solidputfaces
7829          result2 [couleurfacecoupe lescouleurs2 aload pop] solidputfcolors
7830          result2 IO2 dup dup 1 get 1 add 1 exch put solidputinouttable
7831          result1 [facecoupe reverse lesfaces1 aload pop] solidputfaces
7832          result1 [couleurfacecoupe lescouleurs1 aload pop] solidputfcolors
7833          result1 dup solidgetinouttable dup dup 1 get 1 add 1 exch put solidputinouttable
7834       } {
7835          %% l'orientation est ok
7836          result2 IO2 dup dup 1 get 1 add 1 exch put solidputinouttable
7837          result2 [facecoupe reverse lesfaces2 aload pop] solidputfaces
7838          result2 [couleurfacecoupe lescouleurs2 aload pop] solidputfcolors
7839       } ifelse
7840    } for
7841
7842    %% maintenant on enleve les sommets isoles
7843    /sommetspos [] def
7844    /sommetsneg [] def
7845    %% pour chaque face du cote negatif
7846    0 1 lesneg length 1 sub {
7847       lesneg exch get /i exch def
7848       /F solid i solidgetface def
7849       %% pour chaque sommet de cette face
7850       0 1 F length 1 sub {
7851          /j exch def
7852          /sommet F j get def
7853          %% si le sommet n'est pas encore note
7854          sommet sommetsneg in not {
7855             %% et s'il est isole, on peut l'enlever
7856             result1 sommet solidsommetsadjsommet length 0 eq {
7857                /sommetsneg [sommetsneg aload pop sommet] store
7858             } if
7859          } {
7860             pop
7861          } ifelse
7862       } for
7863    } for
7864    sommetsneg bubblesort reverse {result1 exch solidrmsommet} apply
7865
7866    %% pour chaque face du cote positif
7867    0 1 lespos length 1 sub {
7868       lespos exch get /i exch def
7869       /F solid i solidgetface def
7870       %% pour chaque sommet de cette face
7871       0 1 F length 1 sub {
7872          /j exch def
7873          /sommet F j get def
7874          %% si le sommet n'est pas encore note
7875          sommet sommetspos in not {
7876             %% et s'il est isole, on peut l'enlever
7877             result2 sommet solidsommetsadjsommet length 0 eq {
7878                /sommetspos [sommetspos aload pop sommet] store
7879             } if
7880          } {
7881             pop
7882          } ifelse
7883       } for
7884    } for
7885    sommetspos bubblesort reverse {result2 exch solidrmsommet} apply
7886
7887    result1 result2
7888 end
7889 } def
7890
7891 %%%%% ### solidaffine ###
7892 %% syntaxe : solid coeff i solidaffine -> -
7893 %% syntaxe : solid coeff array solidaffine -> -
7894 %% syntaxe : solid coeff solidaffine -> -
7895 %% syntaxe : solid coeff str solidaffine -> -
7896 %% syntaxe : solid coeff bool solidaffine -> -
7897 /solidaffine {
7898 10 dict begin
7899    dup isbool {
7900       /rmfacecentrale exch def
7901    } {
7902       /rmfacecentrale true def
7903    } ifelse
7904    dup isstring {
7905       /couleurface exch def
7906    } if
7907    2 copy pop issolid {
7908       %% 2 arguments --> on affine tout
7909       2 copy pop solidnombrefaces /n exch def
7910       /table [n 1 sub -1 0 {} for] def
7911    } {
7912       %% 1 tableau --> il donne les faces a enlever
7913       dup isarray {
7914          /table exch bubblesort reverse def
7915       } {
7916       %% 1 seule face a enlever
7917          [ exch ] /table exch def
7918       } ifelse
7919    } ifelse
7920    /coeff exch def
7921    /solid exch def
7922    0 1 table length 1 sub {
7923       /i exch def
7924       solid coeff table i get
7925       currentdict /couleurface known {
7926          couleurface
7927       } if
7928       rmfacecentrale s@lidaffineface
7929    } for
7930 end
7931 } def
7932
7933 %% syntaxe : solid coeff i s@lidaffineface
7934  /s@lidaffineface {
7935 10 dict begin
7936    /rmfacecentrale exch def
7937    dup isstring {
7938       /couleurface exch def
7939    } if
7940    /indice_a_chamfreiner exch def
7941    /i indice_a_chamfreiner def
7942    /coeff exch def
7943    /solid exch def
7944    solid issolid not {
7945       (Erreur : mauvais type d argument dans affine) ==
7946       quit
7947    } if
7948    /n solid solidnombresommets def
7949    /F solid i solidgetsommetsface def
7950    /Findex solid i solidgetface def
7951    /ni F length 3 idiv def
7952    /couleurfaceorigine solid i solidgetfcolor def
7953    F isobarycentre3d /G defpoint3d
7954    %% on ajoute les nouveaux sommets
7955    /Sindex [] def
7956    0 1 ni 1 sub {
7957       /j exch def
7958       /Sindex [ Sindex aload pop
7959          solid G F j getp3d vecteur3d coeff mulv3d G addv3d solidaddsommet
7960       ] store
7961    } for
7962    %% Sindex contient les indices des nouveaux sommets
7963    %% on prepare les faces a ajouter
7964    /facestoadd [] def
7965    /facestoadd [facestoadd aload pop
7966    0 1 ni 1 sub {
7967       /j exch def
7968       [Findex j get
7969       Findex j 1 add ni mod get
7970       Sindex j 1 add ni mod get
7971       Sindex j get]
7972    } for
7973    ] store
7974    0 1 ni 1 sub {
7975       /i exch def
7976       solid facestoadd i get solidaddface
7977    } for
7978    %% on enleve la face d origine
7979    solid indice_a_chamfreiner solidrmface
7980    %% on ajuste les couleurs des nouvelles faces
7981    /N solid solidnombrefaces def
7982    0 1 ni 1 sub {
7983       /i exch def
7984       solid N 1 sub i sub couleurfaceorigine solidputfcolor
7985    } for
7986    %% puis on ajoute eventuellement la face centrale
7987    rmfacecentrale not {
7988       solid
7989       [0 1 ni 1 sub {
7990          /j exch def
7991          Sindex j get
7992       } for]
7993       solidaddface
7994       %% en ajustant la couleur de cette derniere
7995       solid N
7996       currentdict /couleurface known {
7997             couleurface
7998       } {
7999          couleurfaceorigine
8000       } ifelse
8001       solidputfcolor
8002    } if
8003 end
8004 } def
8005
8006 %%%%% ### solidtronque ###
8007 %% syntaxe : solid indicesommet k solidtronque --> solid
8008 %% syntaxe : solid array k solidtronque --> solid
8009 %% syntaxe : solid k solidtronque --> solid
8010 %% k entier > 0, array = tableau des indices des sommets
8011 /solidtronque {
8012 10 dict begin
8013    /coeff exch def
8014    dup issolid {
8015       dup solidnombresommets /N exch def
8016       /table [0 1 N 1 sub {} for] def
8017    } {
8018       dup isarray {
8019          /table exch def
8020       } {
8021          [ exch ] /table exch def
8022       } ifelse
8023    } ifelse
8024    /solid exch def
8025    solid dupsolid /result exch def pop
8026    /n solid solidnombrefaces def
8027    0 1 table length 1 sub {
8028       table exch get /no exch def
8029       result no solidgetsommet /sommetvise defpoint3d
8030       %% on recup les sommets adjacents au sommet vise
8031       /sommetsadj solid no solidsommetsadjsommet def
8032       %% on calcule les nouveaux sommets
8033       /nouveauxsommets [
8034          0 1 sommetsadj length 1 sub {
8035             /i exch def
8036             solid sommetsadj i get solidgetsommet
8037          } for
8038       ] {sommetvise exchp3d coeff ABpoint3d} papply3d def
8039       %% on pose G = barycentre de ces points
8040       nouveauxsommets isobarycentre3d /G defpoint3d
8041       %% il faut ordonner ces sommets
8042       nouveauxsommets 0 getp3d /ptref defpoint3d
8043       G result no solidgetsommet vecteur3d /vecteurnormal defpoint3d
8044       %% on construit le tableau des angles ordonnes par rapport
8045       %% a la normale
8046       nouveauxsommets duparray exch pop
8047       {1 dict begin
8048          /M defpoint3d
8049          G ptref vecteur3d
8050          G M vecteur3d
8051          vecteurnormal angle3doriente
8052       end} papply3d
8053       doublebubblesort pop
8054       %% nos sommets sont tries
8055       /indicesommetstries exch def
8056       %% on rajoute les sommets au solide, et on note les nouveaux indices
8057       /nouveauxindices [
8058          0 1 nouveauxsommets length 3 idiv 1 sub {
8059             /k exch def
8060             result nouveauxsommets k getp3d solidaddsommet
8061          } for
8062       ] def
8063       %% on ajoute la face concernee
8064       result [
8065          0 1 indicesommetstries length 1 sub {
8066             /k exch def
8067          nouveauxindices indicesommetstries k get get
8068          } for
8069       ] solidaddface
8070       result no solidfacesadjsommet /lesfaces exch def
8071       %% on examine la face d indice i, et on elimine le
8072       %% sommet vise
8073       0 1 lesfaces length 1 sub {
8074          /i exch def
8075          /j lesfaces i get def
8076          /F result j solidgetface def
8077          result [
8078             0 1 F length 1 sub {
8079                /k exch def
8080                F k get dup no eq {pop} if
8081             } for
8082          ] j exch solidputface
8083       } for
8084    } for
8085    table bubblesort reverse {result exch solidrmsommet} apply
8086    result
8087 end
8088 } def
8089
8090 %%%%% ### dualpolyedre ###
8091 %% syntaxe : solid dualpolyedreregulier --> solid
8092 %% syntaxe : solid r dualpolyedreregulier --> solid
8093 %% si le nombre r est present, projette les nouveaux sommets sur la sphere de centre O , de rayon r
8094 /dualpolyedreregulier {
8095 20 dict begin
8096    dup isnum {
8097       /r exch def
8098       /projection true def
8099    } {
8100       /projection false def
8101    } ifelse
8102    /solid exch def
8103    solid dupsolid /result exch def pop
8104    /n solid solidnombrefaces def
8105    /N solid solidnombresommets def
8106    /facesaenlever [] def
8107    %% pour chacun des sommets
8108    0 1 N 1 sub {
8109       %% sommet d indice i
8110       /i exch def
8111       %% indicesfacesadj = liste des indices des faces ou on trouve le sommet i
8112       /indicesfacesadj solid i solidfacesadjsommet def
8113       %% on recupere les centres des faces concernees
8114       /nouveauxsommets [
8115          0 1 indicesfacesadj length 1 sub {
8116             /k exch def
8117             solid indicesfacesadj k get solidgetsommetsface isobarycentre3d
8118          } for
8119       ] def
8120       %% et on pose G = barycentre de ces points
8121       nouveauxsommets isobarycentre3d /G defpoint3d
8122       %% il faut ordonner ces sommets
8123       nouveauxsommets 0 getp3d /ptref defpoint3d
8124       G solid i solidgetsommet vecteur3d /vecteurnormal defpoint3d
8125       nouveauxsommets duparray exch pop
8126       {1 dict begin
8127          /M defpoint3d
8128          G ptref vecteur3d
8129          G M vecteur3d
8130          vecteurnormal angle3doriente
8131       end} papply3d
8132       doublebubblesort pop
8133       %% nos sommets sont tries
8134       /indicesommetstries exch def
8135       projection {
8136          %% on projette les sommets sur la sphere
8137          /nouveauxsommets [ nouveauxsommets {normalize3d r mulv3d} papply3d aload pop ] store
8138       } if
8139       %% puis on les rajoute au solide
8140       /nouveauxindices [
8141          0 1 nouveauxsommets length 3 idiv 1 sub {
8142             /k exch def
8143             result nouveauxsommets k getp3d solidaddsommet
8144          } for
8145       ] def
8146       %% ainsi que la face concernee
8147       result [
8148          0 1 indicesommetstries length 1 sub {
8149             /k exch def
8150          nouveauxindices indicesommetstries k get get
8151          } for
8152       ] solidaddface
8153       /facesaenlever [ facesaenlever aload pop indicesfacesadj aload pop ] store
8154    } for
8155    result [0 1 n 1 sub {} for] solidrmfaces
8156    [N 1 sub -1 0 {} for] {result exch solidrmsommet} apply
8157    result
8158 end
8159 } def
8160
8161 %%%%% ### newgeode ###
8162 %% syntaxe : solid r newgeode --> solid
8163 %% syntaxe : N r newgeode --> solid
8164 %% N in {3,4,5} -> polyhedre de depart, r = niveau de recursion
8165 /newgeode {
8166 2 dict begin
8167    /r exch def
8168    dup issolid not {
8169       /N exch def
8170       N 3 eq {
8171          1 newtetraedre
8172       } {
8173          N 4 eq {
8174             1 newoctaedre
8175          } {
8176             1 newicosaedre
8177          } ifelse
8178       } ifelse
8179    } if
8180
8181    r {
8182       15 dict begin
8183          /solid exch def
8184          solid dupsolid /result exch def pop
8185          /n solid solidnombrefaces def
8186          n 1 sub -1 0 {
8187             /i exch def
8188             %% la face d indice i
8189             solid i solidgetface /F exch def
8190             /i0 F 0 get def
8191             /i1 F 1 get def
8192             /i2 F 2 get def
8193             solid i0 solidgetsommet /A0 defpoint3d
8194             solid i1 solidgetsommet /A1 defpoint3d
8195             solid i2 solidgetsommet /A2 defpoint3d
8196             A0 A1 milieu3d normalize3d /A01 defpoint3d
8197             A1 A2 milieu3d normalize3d /A12 defpoint3d
8198             A2 A0 milieu3d normalize3d /A20 defpoint3d
8199             result A01 solidaddsommet /i01 exch def
8200             result A12 solidaddsommet /i12 exch def
8201             result A20 solidaddsommet /i20 exch def
8202             result i solidrmface
8203             result [i0 i01 i20] solidaddface
8204             result [i01 i1 i12] solidaddface
8205             result [i01 i12 i20] solidaddface
8206             result [i20 i12 i2] solidaddface
8207          } for
8208          result
8209       end
8210    } repeat
8211 end
8212 } def
8213
8214 %% syntaxe : N r newdualgeode --> solid
8215 /newdualgeode {
8216    newgeode 1
8217    dualpolyedreregulier
8218 } def
8219
8220 %%%%% ### fin insertion ###
8221
8222
8223 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
8224 %%%%             quelques solides precalcules           %%%%
8225 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
8226
8227 %%%%% ### newface ###
8228 %% syntaxe : array newmonoface -> solid
8229 %% ou array = tableau de points 2d
8230 /newmonoface {
8231 4 dict begin
8232    /table exch def
8233    /n table length 2 idiv def
8234    /S table {0} papply def
8235
8236    /F [
8237        [0 1 n 1 sub {} for]
8238    ] def
8239    S F generesolid
8240 end
8241 } def
8242
8243 %% syntaxe : array newbiface -> solid
8244 %% ou array = tableau de points 2d
8245 /newbiface {
8246    newmonoface
8247    dup videsolid
8248 } def
8249
8250 %%%%% ### newpolreg ###
8251 %% syntaxe : r n newpolreg --> solid
8252 /newpolreg {
8253 5 dict begin
8254    /n exch def
8255    /r exch def
8256    /S [
8257        0 360 n div 360 360 n div sub {
8258            /theta exch def
8259            theta cos r mul
8260            theta sin r mul
8261            0
8262        } for
8263    ] def
8264    /F [
8265        [0 1 n 1 sub {} for]
8266    ] def
8267
8268    S F generesolid
8269    dup videsolid
8270 end
8271 } def
8272
8273 %%%%% ### newgrille ###
8274 %% syntaxe : xmin xmax ymin ymax [dx dy] newgrille -> solid
8275 %% syntaxe : xmin xmax ymin ymax [nx ny] newgrille -> solid
8276 %% syntaxe : xmin xmax ymin ymax {mode} newgrille -> solid
8277 %% syntaxe : xmin xmax ymin ymax newgrille -> solid
8278 /newgrille {
8279 10 dict begin
8280    [[/nx /ny] [1 1] [1. 1.] [1. 1.] [1. 1.] [.5 .5]] gestionsolidmode
8281    %% ny nb d etages en y
8282    %% nx nb d etages en x
8283    /biface false def
8284    [nx ny] {0} newsurfaceparametree
8285 end
8286 } def
8287
8288 %% %% syntaxe : xmin xmax ymin ymax [dx dy] {f} newsurface -> solid
8289 %% %% f : R^2 -> R
8290 /newsurface {
8291    true newsurfaceparametree
8292 } def
8293
8294 /biface true def
8295
8296 /newsurfaceparametree {
8297 10 dict begin
8298    dup isbool {
8299       pop /surfz true def
8300    } {
8301       /surfz false def
8302    } ifelse
8303    /f_surface exch def
8304    [[/nx /ny] [2 2] [4 4] [1. 1.] [1. 1.] [.25 .25]] gestionsolidmode
8305    %% ny nb d etages en y
8306    %% nx nb d etages en x
8307    /ymax exch def
8308    /ymin exch def
8309    /xmax exch def
8310    /xmin exch def
8311
8312    nx isinteger not {
8313        %% alors nx est un dx
8314        /nx xmax xmin sub nx div cvi store
8315    } if
8316    ny isinteger not {
8317        %% alors ny est un dy
8318        /ny ymax ymin sub ny div cvi store
8319    } if
8320    /dy ymax ymin sub ny div def %% le pas sur y
8321    /dx xmax xmin sub nx div def %% le pas sur x
8322
8323    /S [
8324        0 1 nx {
8325            /i exch def
8326            0 1 ny {
8327                /j exch def
8328                /u xmin i dx mul add def
8329                /v ymin j dy mul add def
8330                u v
8331                surfz {2 copy} if
8332                f_surface
8333                pstrickactionR3
8334            } for
8335        } for
8336    ] def
8337
8338    /F [
8339        0 1 nx 1 sub {
8340           /i exch def
8341           0 1 ny 1 sub {
8342              /j exch def
8343              [
8344                 j 1 add        i ny 1 add mul add
8345                 j              i ny 1 add mul add
8346                 j ny 1 add add i ny 1 add mul add
8347                 j ny 2 add add i ny 1 add mul add
8348              ]
8349           } for
8350        } for
8351 %%       0 1 0 {%nx 1 sub {
8352 %%          /i exch def
8353 %%          0 1 0 {%ny 2 sub {
8354 %%             /j exch def
8355 %%             [
8356 %%             j 1 add        %% i ny mul add
8357 %%             j              %% i ny mul add
8358 %%             ny 1 add j add       %% i ny mul add
8359 %%             ny 2 add j add     %% i ny mul add
8360 %%             ]
8361 %%          } for
8362 %%       } for
8363    ] def
8364    S F generesolid
8365    biface pl@n-en-cours not and {dup videsolid} if
8366 end
8367 } def
8368
8369 %%%%% ### newgrillecirculaire ###
8370 %% syntaxe : r option newgrillecirculaire -> solid
8371 /newgrillecirculaire {
8372 6 dict begin
8373    [[/K /N] [6 6] [6 8] [10 8] [16 12] [16 36]] gestionsolidmode
8374
8375    %% N = nb de meridiens (diviseur de 360 = 2^4 * 3^2 * 5)
8376    %% K = nb d horizontales (diviseur de 160 = 2^5 * 5)
8377
8378    /r exch def
8379    /F [
8380        %% 1er etage
8381        1 1 N {
8382            /i exch def
8383            [0 i i N mod 1 add]
8384        } for
8385        %% etages suivants
8386        0 1 K 2 sub {
8387            /j exch def
8388            1 1 N {
8389                /i exch def
8390                [i      j N mul add
8391                i N add j N mul add
8392                i N mod N add 1 add j N mul add
8393                i N mod 1 add j N mul add]
8394            } for
8395       } for
8396    ] def
8397
8398    %% tableau des sommets
8399    /S [
8400        0 0 0
8401        1 1 K {
8402            /j exch def
8403            1 1 N {
8404              /i exch def
8405              /theta i 360 mul N div def
8406              theta cos r j mul K div mul
8407              theta sin r j mul K div mul
8408              0 %2 copy f %exch atan 90 div
8409           } for
8410        } for
8411    ] def
8412
8413    S F generesolid
8414 end
8415 } def
8416
8417 %% syntaxe : r [dx dy] {f} newsurface* -> solid
8418 /newsurface* {
8419 7 dict begin
8420    /f_surface exch def
8421    [[/nx /ny] [6 6] [6 8] [10 8] [16 12] [16 36]] gestionsolidmode
8422
8423    nx isinteger not {
8424        %% alors nx est un dx
8425        /nx xmax xmin sub nx div cvi store
8426    } if
8427    ny isinteger not {
8428        %% alors ny est un dy
8429        /ny ymax ymin sub ny div cvi store
8430    } if
8431    /dy ymax ymin sub ny div def %% le pas sur y
8432    /dx xmax xmin sub nx div def %% le pas sur x
8433
8434    %% ny = nb de meridiens
8435    %% nx = nb d horizontales
8436
8437    /r exch def
8438    /F [
8439        %% 1er etage
8440        1 1 ny {
8441            /i exch def
8442            [0 i i ny mod 1 add]
8443        } for
8444        %% etages suivants
8445        0 1 nx 2 sub {
8446            /j exch def
8447            1 1 ny {
8448                /i exch def
8449                [i      j ny mul add
8450                i ny add j ny mul add
8451                i ny mod ny add 1 add j ny mul add
8452                i ny mod 1 add j ny mul add]
8453            } for
8454       } for
8455    ] def
8456
8457    %% tableau des sommets
8458    /S [
8459        0 0 0 0 f_surface
8460        1 1 nx {
8461            /j exch def
8462            1 1 ny {
8463              /i exch def
8464              /theta i 360 mul ny div def
8465              theta cos r j mul nx div mul
8466              theta sin r j mul nx div mul
8467              2 copy f_surface
8468           } for
8469        } for
8470    ] def
8471
8472    S F generesolid
8473 end
8474 } def
8475
8476 %%%%% ### newruban ###
8477 %% syntaxe : array h u [n] newruban -> solid d axe (O, u), de maillage vertical n
8478 %% syntaxe : array h u newruban -> solid d axe (O, u),
8479 %% syntaxe : array h newruban -> solid d axe (O, k),
8480 %% ou array tableau de points 2d
8481 /newruban {
8482 7 dict begin
8483    %% N = nb d etages
8484    [[/N] [1] [1] [1] [3] [4]] gestionsolidmode
8485    2 copy pop isarray {
8486       /u {0 0 1} def
8487    } {
8488       /u defpoint3d
8489    } ifelse
8490    u 0 eq {
8491       (Error : 3eme composante nulle dans le vecteur pour newruban) ==
8492       quit
8493    } if
8494    pop pop
8495    /h exch def
8496    /table exch def
8497    %% n = indice du dernier point
8498    /n table length 2 idiv 1 sub def
8499    %% vecteur de translation
8500    u
8501    h u norme3d div
8502    mulv3d /v defpoint3d
8503
8504    %% tableau des sommets
8505    /S [
8506       0 1 N {
8507          /j exch def
8508          0 1 n {
8509              /i exch def
8510              table i getp
8511              0
8512              v N j sub N div mulv addv3d
8513          } for
8514       } for
8515    ] def
8516
8517    /F [
8518       %% faces etage
8519       1 1 N {
8520          /j exch def
8521          1 1 n {
8522              /i exch def
8523              [i                   j 1 sub n 1 add mul add
8524               i 1 sub             j 1 sub n 1 add mul add
8525               n 1 add i add 1 sub j 1 sub n 1 add mul add
8526               n 1 add i add       j 1 sub n 1 add mul add]
8527          } for
8528      } for
8529    ] def
8530
8531    S F generesolid
8532    dup videsolid
8533 end
8534 } def
8535
8536 %%%%% ### newicosaedre ###
8537 /newicosaedre {
8538 3 dict begin
8539    /a exch def
8540    /S [
8541       0.8944271  0              0.4472137
8542       0.2763932  0.8506507      0.4472137
8543       -0.7236067 0.5257311      0.4472137
8544       -0.7236067 -0.5257311     0.4472137
8545       0.2763932  -0.8506507     0.4472137
8546       0          0              1
8547       0          0              -1
8548       -0.8944271 0              -0.4472137
8549       -0.2763932 -0.8506507     -0.4472137
8550       0.7236067  -0.5257311     -0.4472137
8551       0.7236067  0.5257311      -0.4472137
8552       -0.2763932 0.8506507      -0.4472137
8553    ] {a mulv3d} papply3d def
8554
8555    /F [
8556       [0 1 5]   %% 1  2 6  ]
8557       [1 2 5]   %% 2  3 6  ]
8558       [2 3 5]   %% 3  4 6  ]
8559       [3 4 5]   %% 4  5 6  ]
8560       [4 0 5]   %% 5  1 6  ]
8561       [9 0 4]   %% 10 1 5  ]
8562       [0 9 10]  %% 1  10 11]
8563       [10 1 0]  %% 11 2 1  ]
8564       [1 10 11] %% 2  11 12]
8565       [11 2 1]  %% 12 3 2  ]
8566       [2 11 7]  %% 3  12 8 ]
8567       [2 7 3]   %% 3  8 4  ]
8568       [3 7 8]   %% 4  8 9  ]
8569       [3 8 4]   %% 4  9 5  ]
8570       [4 8 9]   %% 5  9 10 ]
8571       [6 7 11]  %% 7  8 12 ]
8572       [6 8 7]   %% 7  9 8  ]
8573       [6 9 8]   %% 7  10 9 ]
8574       [6 10 9]  %% 7  11 10]
8575       [6 11 10] %% 7  12 11]
8576    ] def
8577
8578    S F generesolid
8579 end
8580 } def
8581
8582 %%%%% ### newdodecaedre ###
8583 /newdodecaedre {
8584 3 dict begin
8585    /a exch def
8586    /S [
8587       0          0.607062   0.7946545
8588       -0.5773503 0.1875925  0.7946545
8589       -0.3568221 -0.4911235 0.7946545
8590       0.3568221  -0.4911235 0.7946545
8591       0.5773503  0.1875925  0.7946545
8592       0          0.982247   0.1875925
8593       -0.9341724 0.303531   0.1875925
8594       -0.5773503 -0.7946645 0.1875925
8595       0.5773503  -0.7946645 0.1875925
8596       0.9341724  0.303531   0.1875925
8597       0          -0.982247  -0.1875925
8598       0.9341724  -0.303531  -0.1875925
8599       0.5773503  0.7946545  -0.1875925
8600       -0.5773503 0.7946545  -0.1875925
8601       -0.9341724 -0.303531  -0.1875925
8602       -0.5773503 -0.1875925 -0.7946545
8603       -0.3568221 0.4911235  -0.7946545
8604       0.3568221  0.4911235  -0.7946545
8605       0.5773503  -0.1875925 -0.7946545
8606       0          -0.607062  -0.7946545
8607    ] {a mulv3d} papply3d def
8608
8609    /F [
8610       [0 1 2 3 4]
8611       [4 3 8 11 9]
8612       [4 9 12 5 0]
8613       [0 5 13 6 1]
8614       [1 6 14 7 2]
8615       [2 7 10 8 3]
8616       [10 19 18 11 8]
8617       [11 18 17 12 9]
8618       [12 17 16 13 5]
8619       [13 16 15 14 6]
8620       [14 15 19 10 7]
8621       [15 16 17 18 19]
8622    ] def
8623    S F generesolid
8624 end
8625 } def
8626
8627 %%%%% ### newoctaedre ###
8628 /newoctaedre {
8629 3 dict begin
8630    /a exch def
8631    %%Sommets
8632    /S [
8633       0  0  1
8634       1  0  0
8635       0  1  0
8636       -1 0  0
8637       0  -1 0
8638       0  0  -1
8639    ] {a mulv3d} papply3d def
8640
8641    /F [
8642       [0 4 1]
8643       [1 2 0]
8644       [0 2 3]
8645       [3 4 0]
8646       [1 5 2]
8647       [2 5 3]
8648       [3 5 4]
8649       [4 5 1]
8650    ] def
8651
8652    S F generesolid
8653 end
8654 } def
8655
8656 %%%%% ### newtetraedre ###
8657 /newtetraedre {
8658 3 dict begin
8659    /r exch def
8660    %%Tetraedre
8661    /S [
8662       0          0          1
8663       -0.4714045 -0.8164965 -1 3 div
8664       0.942809   0          -1 3 div
8665       -0.4714045 0.8164965  -1 3 div
8666    ] {r mulv3d} papply3d def
8667
8668    /F [
8669       [0 1 2]
8670       [0 2 3]
8671       [0 3 1]
8672       [1 3 2]
8673    ] def
8674
8675    S F generesolid
8676 end
8677 } def
8678
8679 %%%%% ### newcube ###
8680 /newcube {
8681 3 dict begin
8682    [[/n] [1] [1] [1] [3] [4]] gestionsolidmode
8683    /a exch 2 div def
8684
8685    n 1 le {
8686       /F [
8687      [0 1 2 3]
8688      [0 4 5 1]
8689      [1 5 6 2]
8690      [2 6 7 3]
8691      [0 3 7 4]
8692      [4 7 6 5]
8693       ] def
8694
8695       %% tableau des sommets
8696       /S [
8697       1  1  1 %% 0
8698      -1  1  1 %% 1
8699      -1 -1  1 %% 2
8700       1 -1  1 %% 3
8701       1  1 -1 %% 4
8702      -1  1 -1 %% 5
8703      -1 -1 -1 %% 6
8704       1 -1 -1 %% 7
8705       ] {a mulv3d} papply3d def
8706       S F generesolid
8707    } {
8708       /dl 2 n div def
8709       /N n dup mul n add 4 mul def
8710       /n1 n 1 sub dup mul def %% nb sommets centre d une face
8711
8712       %% tableau des sommets
8713       /S1 [
8714      0 1 n 1 sub {
8715         /j exch def
8716         0 1 n {
8717            /i exch def
8718            -1 i dl mul add
8719            -1 j dl mul add
8720         1
8721         } for
8722      } for
8723       ] def
8724
8725       /S2 S1 {-90 0 0 rotateOpoint3d} papply3d def
8726       /S3 S2 {-90 0 0 rotateOpoint3d} papply3d def
8727       /S4 S3 {-90 0 0 rotateOpoint3d} papply3d def
8728
8729       /S5 [
8730      1 1 n 1 sub {
8731         /j exch def
8732         1 1 n 1 sub {
8733            /i exch def
8734         1
8735            -1 i dl mul add
8736            -1 j dl mul add
8737         } for
8738      } for
8739       ] def
8740
8741       /S6 [
8742      1 1 n 1 sub {
8743         /j exch def
8744         1 1 n 1 sub {
8745            /i exch def
8746            -1
8747            -1 i dl mul add
8748            -1 j dl mul add
8749         } for
8750      } for
8751       ] def
8752
8753       %% tableau des faces
8754       /F1 [
8755      0 1 n 1 sub {
8756         /j exch def
8757         0 1 n 1 sub {
8758            /i exch def
8759            [
8760           i n 1 add j mul add
8761           dup 1 add
8762           dup n 1 add add
8763           dup 1 sub
8764            ]
8765         } for
8766      } for
8767       ] def
8768
8769       %% syntaxe : i sommettourgauche --> l indice du i-eme sommet du tour
8770       %% de la face gauche (en commencant par l indice 0). ATTENTION :
8771       %% utilise la variable globale n = nb d etages
8772       /sommettourgauche {
8773       1 dict begin
8774      /i exch def
8775      i 4 n mul ge {
8776         i
8777         (Error: indice trop grand dans sommettourgauche) ==
8778         exit
8779      } if
8780      n n 1 add i mul add
8781       end
8782       } def
8783
8784       %% syntaxe : i sommetcentregauche --> l indice du i-eme sommet du centre
8785       %% de la face gauche (en commencant par l indice 0). ATTENTION :
8786       %% utilise les variables globales n = nb d etages, et N = nb sommets
8787       %% des 4 1eres faces
8788       /sommetcentregauche {
8789       1 dict begin
8790      /i exch def
8791      i n 1 sub dup mul ge {
8792         i
8793         (Error: indice trop grand dans sommetcentregauche) ==
8794         exit
8795      } if
8796      N i add
8797       end
8798       } def
8799
8800       /F5 [
8801      %%%%% la face gauche %%%%%
8802      %% le coin superieur gauche
8803      [
8804         1 sommettourgauche
8805         0 sommettourgauche
8806         n 4 mul 1 sub sommettourgauche
8807         n1 n 1 sub sub sommetcentregauche
8808      ]
8809
8810      %% la bande superieure (i from 1 to n-2)
8811      1 1 n 2 sub {
8812         /i exch def
8813         [
8814            i 1 add sommettourgauche
8815            i sommettourgauche
8816            n1 n sub i add sommetcentregauche
8817            n1 n sub i 1 add add sommetcentregauche
8818         ]
8819      } for
8820
8821      %% le coin superieur droit
8822      [
8823         n sommettourgauche
8824         n 1 sub sommettourgauche
8825         n1 1 sub sommetcentregauche
8826         n 1 add sommettourgauche
8827      ]
8828
8829      %% la descente gauche
8830      %% j from 1 to n-2
8831      1 1 n 2 sub {
8832         /j exch def
8833         [
8834            n1 n 1 sub j mul sub sommetcentregauche
8835            n 4 mul j sub sommettourgauche
8836            n 4 mul j 1 add sub sommettourgauche
8837            n1 n 1 sub j 1 add mul sub sommetcentregauche
8838         ]
8839      } for
8840
8841      %% les bandes centrales (j from 1 to n-2 et i from 1 to n-2)
8842      1 1 n 2 sub {
8843         /j exch def
8844         1 1 n 2 sub {
8845            /i exch def
8846            [
8847           n1 i n 1 sub j 1 sub mul add sub sommetcentregauche
8848           n1 i 1 add n 1 sub j 1 sub mul add sub sommetcentregauche
8849           n1 i 1 add n 1 sub j mul add sub sommetcentregauche
8850           n1 i n 1 sub j mul add sub sommetcentregauche
8851            ]
8852         } for
8853      } for
8854
8855      %% la descente droite
8856      1 1 n 2 sub {
8857         /j exch def
8858         [
8859            n j add sommettourgauche
8860            n1 1 sub j 1 sub n 1 sub mul sub sommetcentregauche
8861            n1 1 sub j n 1 sub mul sub sommetcentregauche
8862            n j 1 add add sommettourgauche
8863         ]
8864      } for
8865
8866      %% le coin inferieur gauche
8867      [
8868         0 sommetcentregauche
8869         n 3 mul 1 add sommettourgauche
8870         n 3 mul sommettourgauche
8871         n 3 mul 1 sub sommettourgauche
8872      ]
8873
8874      %% la bande inferieure (i from 1 to n-2)
8875      1 1 n 2 sub {
8876         /i exch def
8877         [
8878            i sommetcentregauche
8879            i 1 sub sommetcentregauche
8880            n 3 mul i sub sommettourgauche
8881            n 3 mul i sub 1 sub sommettourgauche
8882         ]
8883      } for
8884
8885      %% le coin inferieur droit
8886      [
8887         n 2 mul 1 sub sommettourgauche
8888         n 2 sub sommetcentregauche
8889         n 2 mul 1 add sommettourgauche
8890         n 2 mul sommettourgauche
8891      ]
8892       ] def
8893
8894       %% syntaxe : i sommettourdroit --> l indice du i-eme sommet du tour
8895       %% de la face droit (en commencant par l indice 0). ATTENTION :
8896       %% utilise la variable globale n = nb d etages
8897       /sommettourdroit {
8898       1 dict begin
8899      /i exch def
8900      i 4 n mul ge {
8901         i
8902         (Error: indice trop grand dans sommettourdroit) ==
8903         exit
8904      } if
8905      n 1 add i mul
8906       end
8907       } def
8908
8909       %% syntaxe : i sommetcentredroit --> l indice du i-eme sommet du centre
8910       %% de la face droit (en commencant par l indice 0). ATTENTION :
8911       %% utilise les variables globales n = nb d etages, et N = nb sommets
8912       %% des 4 1eres faces
8913       /sommetcentredroit {
8914       1 dict begin
8915      /i exch def
8916      i n 1 sub dup mul ge {
8917         i
8918         (Error: indice trop grand dans sommetcentredroit) ==
8919         exit
8920      } if
8921      N n1 add i add
8922       end
8923       } def
8924
8925       /F6 [
8926      %% coin superieur droit
8927      [
8928         0 sommettourdroit
8929         1 sommettourdroit
8930         n1 n 1 sub sub sommetcentredroit
8931         4 n mul 1 sub sommettourdroit
8932      ]
8933      %% coin superieur gauche
8934      [
8935         n 1 sub sommettourdroit
8936         n sommettourdroit
8937         n 1 add sommettourdroit
8938         n1 1 sub sommetcentredroit
8939      ]
8940      %% coin inferieur gauche
8941      [
8942         n 2 sub sommetcentredroit
8943         2 n mul 1 sub sommettourdroit
8944         2 n mul sommettourdroit
8945         2 n mul 1 add sommettourdroit
8946      ]
8947      %% coin inferieur droit
8948      [
8949         3 n mul 1 add sommettourdroit
8950         0 sommetcentredroit
8951         3 n mul 1 sub sommettourdroit
8952         3 n mul sommettourdroit
8953      ]
8954      %% bande superieure
8955      1 1 n 2 sub {
8956         /i exch def
8957         [
8958            i sommettourdroit
8959            i 1 add sommettourdroit
8960            n 1 sub n 2 sub mul i add sommetcentredroit
8961            n 1 sub n 2 sub mul i 1 sub add sommetcentredroit
8962         ]
8963      } for
8964      %% bande inferieure
8965      1 1 n 2 sub {
8966         /i exch def
8967         [
8968            i 1 sub sommetcentredroit
8969            i sommetcentredroit
8970            3 n mul 1 sub i sub sommettourdroit
8971            3 n mul i sub sommettourdroit
8972         ]
8973      } for
8974      %% descente gauche
8975      1 1 n 2 sub {
8976         /i exch def
8977         [
8978            n1 1 sub i 1 sub n 1 sub mul sub sommetcentredroit
8979            n i add sommettourdroit
8980            n i 1 add add sommettourdroit
8981            n1 1 sub i n 1 sub mul sub sommetcentredroit
8982         ]
8983      } for
8984      %% descente droite
8985      1 1 n 2 sub {
8986         /i exch def
8987         [
8988            4 n mul i sub sommettourdroit
8989            n 1 sub n 1 sub i sub mul sommetcentredroit
8990            n 1 sub n 2 sub i sub mul sommetcentredroit
8991            4 n mul i sub 1 sub sommettourdroit
8992         ]
8993      } for
8994      %% bandes interieures
8995      1 1 n 2 sub {
8996         /j exch def
8997         1 1 n 2 sub {
8998            /i exch def
8999            [
9000           n 1 sub j mul i 1 sub add sommetcentredroit
9001           n 1 sub j mul i add sommetcentredroit
9002           n 1 sub j 1 sub mul i add sommetcentredroit
9003           n 1 sub j 1 sub mul i 1 sub add sommetcentredroit
9004            ]
9005         } for
9006      } for
9007
9008       ] def
9009
9010       /F2 F1 {{n dup mul n add add} apply} apply def
9011       /F3 F2 {{n dup mul n add add} apply} apply def
9012       /F4 F3 {{n dup mul n add add} apply} apply def
9013
9014
9015       S1 S2 append S3 append S4 append S5 append S6 append {a mulv3d} papply3d
9016       F1 F2 append F3 append F4 append {{N mod} apply} apply F5 append F6 append
9017       generesolid
9018    } ifelse
9019 end
9020 } def
9021
9022 %%%%% ### newparallelepiped ###
9023 % 14 octobre 2006
9024 /newparallelepiped {
9025 2 dict begin
9026    /c exch 2 div def
9027    /b exch 2 div def
9028    /a exch 2 div def
9029    /F [
9030       [0 1 2 3]
9031       [0 4 5 1]
9032       [1 5 6 2]
9033       [2 6 7 3]
9034       [0 3 7 4]
9035       [4 7 6 5]
9036     ] def
9037
9038     %% tableau des sommets
9039     /S [
9040        a     b     c %% 0
9041        a neg b     c %% 1
9042        a neg b neg c %% 2
9043        a     b neg c %% 3
9044        a     b     c neg %% 4
9045        a neg b     c neg %% 5
9046        a neg b neg c neg %% 6
9047        a     b neg c neg %% 7
9048     ] def
9049     S F generesolid
9050 end
9051 } def
9052
9053 %%%%% ### newcylindre ###
9054 %% syntaxe : z0 r0 z1 newcylindre -> solide
9055 %% syntaxe : z0 r0 z1 {mode} newcylindre -> solide
9056 %% syntaxe : z0 r0 z1 [n1 n2] newcylindre -> solide
9057 %% syntaxe : a b {f} {u} h [n1 n2] newcylindre
9058 /newcylindre {
9059 2 dict begin
9060    [[/n2 /n1] [1 6] [1 8] [1 10] [3 12] [5 18]] gestionsolidmode
9061    2 copy pop xcheck {
9062       %% cylindre cas general
9063       /h exch def
9064       /U exch def
9065       U normalize3d /u defpoint3d
9066       /lafonction exch def
9067       /b exch def
9068       /a exch def
9069       /pas b a sub n1 div def
9070       /vpas h n2 div def
9071       /S [
9072          0 1 n2 {
9073             /j exch def
9074             0 1 n1 {
9075                /i exch def
9076                a i pas mul add lafonction
9077                u j vpas mul mulv3d addv3d
9078             } for
9079          } for
9080       ] def
9081       /F [
9082          0 1 n2 1 sub {
9083             /j exch def
9084             0 1 n1 1 sub {
9085                /i exch def
9086                [
9087                   i n1 1 add j mul add
9088                   dup 1 add
9089                   dup n1 1 add add
9090                   dup 1 sub
9091                ]
9092             } for
9093          } for
9094       ] def
9095
9096       S F generesolid
9097 %      dup videsolid
9098    } {
9099       %% cylindre de revolution
9100       2 copy pop [n2 n1] newtronccone
9101    } ifelse
9102 end
9103 } def
9104
9105 %% syntaxe : z0 r0 z1 newcylindrecreux -> solide
9106 /newcylindrecreux {
9107    newcylindre
9108    dup creusesolid
9109 } def
9110
9111 %%%%% ### newtronccone ###
9112 %% syntaxe : z0 r0 z1 r1 newtronccone -> solid
9113 /newtronccone {
9114 11 dict begin
9115    [[/n /N] [1 6] [1 8] [1 10] [3 12] [5 18]] gestionsolidmode
9116
9117    /r1 exch def
9118    /z1 exch def
9119    /r0 exch def
9120    /z0 exch def
9121    /dz z1 z0 sub n div def
9122    /dr r1 r0 sub n div def
9123
9124    /FE [
9125       [0 1 N 1 sub {} for]
9126       [n 1 add N mul 1 sub -1 n N mul {} for]
9127
9128       0 1 n 1 sub {
9129       /k exch def
9130          k N mul 1 add 1 k 1 add N mul 1 sub {
9131              /i exch def
9132              [i i 1 sub N i add 1 sub N i add]
9133          } for
9134          [k N mul k 1 add N mul 1 sub k 2 add N mul 1 sub k 1 add N mul]
9135       } for
9136
9137    ] def
9138
9139    %% tableau des sommets
9140    /S [
9141       n -1 0 {
9142          /k exch def
9143          0 1 N 1 sub {
9144              /i exch def
9145              360 N idiv i mul cos r0 dr k mul add mul
9146              360 N idiv i mul sin r0 dr k mul add mul
9147              z0 dz k mul add
9148          } for
9149       } for
9150    ] def
9151    S FE generesolid
9152 end
9153 } def
9154
9155 %% syntaxe : z0 r0 z1 r1 newtroncconecreux -> solid
9156 /newtroncconecreux {
9157    newtronccone
9158    dup creusesolid
9159 } def
9160
9161 %%%%% ### newcone ###
9162 %% syntaxe : z0 r0 z1 newcone -> solid
9163 %% syntaxe : z0 r0 z1 {mode} newcone -> solid
9164 %% syntaxe : z0 r0 z1 [n1 n2] newcone -> solid
9165 %% syntaxe : a b {f} {sommet} [n1 n2] newcone -> solid
9166 /newcone {
9167 11 dict begin
9168    [ [/n /N] [1 6] [1 8] [1 10] [3 12] [5 18] ] gestionsolidmode
9169    dup xcheck {
9170       %% cas general
9171       /sommet exch def
9172       /lafonction exch def
9173       /b exch def
9174       /a exch def
9175
9176       /pas b a sub N div def
9177       /S [
9178          sommet
9179          0 1 n 1 sub {
9180             /j exch def
9181             0 1 N {
9182                /i exch def
9183                a i pas mul add lafonction
9184                dupp3d sommet vecteur3d j n div mulv3d addv3d
9185             } for
9186          } for
9187          1 1 n {
9188             /j exch def
9189             0 1 N {
9190                /i exch def
9191                a i pas mul add lafonction
9192                sommet vecteur3d j n div mulv3d sommet addv3d
9193             } for
9194          } for
9195       ] def
9196
9197       /F [
9198          %% les etages inferieurs
9199          0 1 n 2 sub {
9200             /j exch def
9201             1 1 N {
9202                /i exch def
9203                [
9204                   i j N 1 add mul add
9205                   dup 1 add
9206                   dup N add 1 add
9207                   dup 1 sub
9208                ]
9209             } for
9210          } for
9211          %% dernier etage inferieur
9212          1 1 N {
9213             /i exch def
9214             [
9215                i N 1 add n 1 sub mul add
9216                dup 1 add
9217                0
9218             ]
9219          } for
9220          %% premier etage superieur
9221          1 1 N {
9222             /i exch def
9223             [
9224                i N 1 add n mul add
9225                dup 1 add
9226                0
9227                exch
9228             ]
9229          } for
9230          %% les etages superieurs
9231          n 1 n 2 mul 2 sub {
9232             /j exch def
9233             1 1 N {
9234                /i exch def
9235                [
9236                   i j N 1 add mul add
9237                   dup 1 add
9238                   dup N add 1 add
9239                   dup 1 sub
9240                ]
9241             } for
9242          } for
9243       ] def
9244
9245       S F generesolid
9246 %      dup videsolid
9247    } {
9248       %% cylindre de revolution
9249       /z1 exch def
9250       /r0 exch def
9251       /z0 exch def
9252       /dz z1 z0 sub n div def
9253       /dr r0 n div def
9254
9255       /F [
9256          %% la base
9257          [N 1 sub -1 0 {} for]
9258          %% le dernier etage
9259          n 1 sub N mul 1 add 1 n N mul 1 sub {
9260               /i exch def
9261               [i 1 sub i n N mul]
9262          } for
9263          [n N mul 1 sub n 1 sub N mul n N mul]
9264          %% les autres etages
9265          0 1 n 2 sub {
9266             /j exch def
9267             0 N j mul add 1 N N j mul add 2 sub {
9268                /i exch def
9269                [i i 1 add dup N add dup 1 sub]
9270             } for
9271             [N N j mul add 1 sub N j mul dup N add dup N add 1 sub]
9272          } for
9273       ] def
9274
9275       %% tableau des sommets
9276       /S [
9277          %% etage no j (in [1; n])
9278          0 1 n 1 sub {
9279             /j exch def
9280             0 1 N 1 sub {
9281                 /i exch def
9282                 360 N idiv i mul cos r0 dr j mul sub mul
9283                 360 N idiv i mul sin r0 dr j mul sub mul
9284                 z0 dz j mul add
9285             } for
9286          } for
9287          0 0 z1
9288       ] def
9289       S F generesolid
9290    } ifelse
9291 end
9292 } def
9293
9294 %% %% syntaxe : z0 r0 z1 newconecreux -> solid
9295  /newconecreux {
9296     newcone
9297     dup 0 solidrmface
9298     dup videsolid
9299  } def
9300
9301 %%%%% ### newtore ###
9302 %% syntaxe : r R newtore -> solid
9303 /newtore {
9304 10 dict begin
9305    [[/n1 /n2] [4 5] [6 10] [8 12] [9 18] [18 36]] gestionsolidmode
9306    /n2 n2 3 max store
9307    /n1 n1 2 max store
9308    /R exch def
9309    /r exch def
9310    /S [
9311          0 1 n1 1 sub {
9312             /i exch def
9313             360 n1 div i mul cos r mul R add
9314             360 n1 div i mul sin r mul
9315          } for
9316       ]
9317    def
9318    S [n2] newanneau
9319 end
9320 } def
9321
9322 %%%%% ### newprisme ###
9323 %% syntaxe : array z0 z1 newprisme -> solid d axe (O, u),
9324 /newprismedroit {
9325    [[/N] [1] [1] [1] [3] [6]] gestionsolidmode
9326    0 0 1 [N] newprisme
9327 } def
9328
9329 %% syntaxe : array z0 z1 u newprisme -> solid d axe (O, u),
9330 %% ou array tableau de points 2d
9331 /newprisme {
9332 7 dict begin
9333    [[/N] [1] [1] [1] [3] [6]] gestionsolidmode
9334    dup 0 eq {
9335       (Error : 3eme composante nulle dans le vecteur pour newprisme) ==
9336       quit
9337    } if
9338    /u defpoint3d
9339    /z1 exch def
9340    /z0 exch def
9341    %% N = nb d etages
9342    /table exch def
9343    %% n = indice du dernier point
9344    /n table length 2 idiv 1 sub def
9345    %% vecteur de translation
9346    u
9347    z1 z0 sub u norme3d div
9348    mulv3d /v defpoint3d
9349
9350    %% tableau des sommets
9351    /S [
9352       0 1 N {
9353          /j exch def
9354          0 1 n {
9355              /i exch def
9356              table i getp
9357              z0
9358              v N j sub N div mulv addv3d
9359          } for
9360       } for
9361    ] def
9362
9363    /F [
9364       %% face superieure
9365       [0 1 n {} for]
9366       %% base
9367       [N 1 add n 1 add mul 1 sub -1 N n 1 add mul {} for]
9368       %% faces etage
9369       1 1 N {
9370          /j exch def
9371          1 1 n {
9372              /i exch def
9373              [i                   j 1 sub n 1 add mul add
9374               i 1 sub             j 1 sub n 1 add mul add
9375               n 1 add i add 1 sub j 1 sub n 1 add mul add
9376               n 1 add i add       j 1 sub n 1 add mul add]
9377          } for
9378          [0            j 1 sub n 1 add mul add
9379          n             j 1 sub n 1 add mul add
9380          2 n mul 1 add j 1 sub n 1 add mul add
9381          n 1 add       j 1 sub n 1 add mul add]
9382      } for
9383    ] def
9384
9385    S F generesolid
9386 end
9387 } def
9388
9389 %%%%% ### newsphere ###
9390 %% syntaxe : r option newsphere -> solid
9391 /newsphere {
9392 2 dict begin
9393    [[/K /N] [6 6] [8 8] [10 12] [16 12] [16 36]] gestionsolidmode
9394    -90 90 [K N] newcalottesphere
9395 end
9396 } def
9397
9398 %% syntaxe : r phi theta option newcalottesphere -> solid
9399 /newcalottesphere {
9400 6 dict begin
9401    [[/K /N] [6 6] [8 8] [10 12] [16 12] [16 36]] gestionsolidmode
9402
9403    %% test de beta (ex-theta)
9404    dup 90 eq {
9405       /beta exch def
9406       /idebut 1 def
9407    } {
9408       /beta exch 80 min -80 max def
9409       /idebut 0 def
9410    } ifelse
9411    %% test de alpha (ex-phi)
9412    dup -90 eq {
9413       /alpha exch def
9414    } {
9415       /alpha exch beta min -80 max def
9416    } ifelse
9417    /r exch def
9418    beta 90 eq {
9419        alpha -90 eq {
9420            /ifin K def
9421           /db alpha beta sub K 1 add div def
9422        } {
9423            /ifin K def
9424           /db alpha beta sub K div def
9425        } ifelse
9426    } {
9427        alpha -90 eq {
9428            /ifin K 1 sub def
9429           /db alpha beta sub K div def
9430        } {
9431            /ifin K 1 sub def
9432           /db alpha beta sub K 1 sub div def
9433        } ifelse
9434    } ifelse
9435
9436    %% nombre de sommets -2
9437    /nb N K mul def
9438
9439    %% tableau des sommets
9440    /S [
9441        idebut 1 ifin {
9442            /j exch def
9443            /phi beta j db mul add def
9444            phi cos r mul /r_tmp exch def
9445            0 1 N 1 sub {
9446                 /i exch def
9447                 360 N idiv i mul cos r_tmp mul
9448                 360 N idiv i mul sin r_tmp mul
9449                 phi sin r mul
9450             } for
9451        } for
9452       0 0 r neg
9453       0 0 r
9454    ] def
9455
9456    /F [
9457      %% calotte inferieure
9458      alpha -90 eq {
9459          1 1 N 1 sub {
9460          /i exch def
9461             [
9462                 nb
9463                 nb i sub
9464                 nb i 1 add sub
9465             ]
9466          } for
9467          [nb nb N sub nb 1 sub]
9468      } {
9469         [nb 1 sub -1 nb N sub {} for ]
9470      } ifelse
9471
9472      %% calotte superieure
9473      beta 90 eq {
9474          0 1 N 1 sub {
9475             /i exch def
9476              [i i 1 add N mod N K mul 1 add]
9477          } for
9478       } {
9479          [0 1 N 1 sub {} for]
9480       } ifelse
9481
9482      1 1 K 1 sub {
9483           /j exch def
9484        [
9485            j N mul
9486            j N mul 1 add
9487            j 1 sub N mul 1 add
9488            j 1 sub N mul
9489        ]
9490        N 2 sub {dup {1 add} apply} repeat
9491        [
9492            j 1 add N mul 1 sub
9493            j N mul
9494            j 1 sub N mul
9495            j N mul 1 sub
9496        ]
9497     } for
9498    ] def
9499
9500    S F generesolid
9501 end
9502 } def
9503
9504 %% syntaxe : r phi theta option newcalottespherecreuse -> solid
9505 /newcalottespherecreuse {
9506 6 dict begin
9507    [[/K /N] [6 6] [8 8] [10 12] [16 12] [16 36]] gestionsolidmode
9508
9509    %% test de beta (ex-theta)
9510    dup 90 eq {
9511       /beta exch def
9512       /idebut 1 def
9513    } {
9514       /beta exch 80 min -80 max def
9515       /idebut 0 def
9516    } ifelse
9517    %% test de alpha (ex-phi)
9518    dup -90 eq {
9519       /alpha exch def
9520    } {
9521       /alpha exch beta min -80 max def
9522    } ifelse
9523    /r exch def
9524    beta 90 eq {
9525        alpha -90 eq {
9526            /ifin K def
9527           /db alpha beta sub K 1 add div def
9528        } {
9529            /ifin K def
9530           /db alpha beta sub K div def
9531        } ifelse
9532    } {
9533        alpha -90 eq {
9534            /ifin K 1 sub def
9535           /db alpha beta sub K div def
9536        } {
9537            /ifin K 1 sub def
9538           /db alpha beta sub K 1 sub div def
9539        } ifelse
9540    } ifelse
9541
9542    %% nombre de sommets -2
9543    /nb N K mul def
9544
9545    %% tableau des sommets
9546    /S [
9547        idebut 1 ifin {
9548            /j exch def
9549            /phi beta j db mul add def
9550            phi cos r mul /r_tmp exch def
9551            0 1 N 1 sub {
9552                 /i exch def
9553                 360 N idiv i mul cos r_tmp mul
9554                 360 N idiv i mul sin r_tmp mul
9555                 phi sin r mul
9556             } for
9557        } for
9558       0 0 r neg
9559       0 0 r
9560    ] def
9561
9562    /F [
9563      %% calotte inferieure
9564      alpha -90 eq {
9565          1 1 N 1 sub {
9566          /i exch def
9567             [
9568                 nb
9569                 nb i sub
9570                 nb i 1 add sub
9571             ]
9572          } for
9573          [nb nb N sub nb 1 sub]
9574      } {
9575 %        [nb 1 sub -1 nb N sub {} for ]
9576      } ifelse
9577
9578      %% calotte superieure
9579      beta 90 eq {
9580          0 1 N 1 sub {
9581             /i exch def
9582              [i i 1 add N mod N K mul 1 add]
9583          } for
9584       } {
9585 %         [0 1 N 1 sub {} for]
9586       } ifelse
9587
9588      1 1 K 1 sub {
9589           /j exch def
9590        [
9591            j N mul
9592            j N mul 1 add
9593            j 1 sub N mul 1 add
9594            j 1 sub N mul
9595        ]
9596        N 2 sub {dup {1 add} apply} repeat
9597        [
9598            j 1 add N mul 1 sub
9599            j N mul
9600            j 1 sub N mul
9601            j N mul 1 sub
9602        ]
9603     } for
9604    ] def
9605
9606    S F generesolid
9607    dup videsolid
9608 end
9609 } def
9610
9611 %%%%% ### newanneau ###
9612 %% syntaxe : array n newanneau --> solid
9613 %% syntaxe : array {mode} newanneau --> solid
9614 %% ou array est un tableau de points de R^2 et n un nombre entier positif
9615 /newanneau {
9616 10 dict begin
9617    dup isnum {
9618       /n exch def
9619       [n]
9620    } if
9621    [[/n2] [6] [12] [24] [32] [36]] gestionsolidmode
9622    /n2 n2 3 max store
9623    %% on plonge la section dans R^3 par projection sur yOz
9624    /S1 exch {0 3 1 roll} papply def
9625    %% nombre de sommets
9626    /n1 S1 length 3 idiv def
9627
9628    /S S1
9629       n2 {
9630          duparray
9631          {0 0 360 n2 div rotateOpoint3d} papply3d
9632       } repeat
9633       n2 {append} repeat
9634    def
9635
9636    /F [
9637       0 1 n2 1 sub {
9638          /j exch def
9639          n1 j mul 1 j 1 add n1 mul 2 sub {
9640             /i exch def
9641             [i 1 add i dup n1 add i n1 1 add add]
9642          } for
9643          [n1 j mul j 1 add n1 mul 1 sub j 2 add n1 mul 1 sub j 1 add n1 mul]
9644       } for
9645    ] def
9646
9647    S F generesolid
9648 end
9649 } def
9650
9651 %%%%% ### newvecteur ###
9652 %% syntaxe : x y z newvecteur
9653 %% syntaxe : x y z array newvecteur
9654 /newvecteur {
9655 4 dict begin
9656    dup isarray {
9657       /table exch def
9658       /h@uteur table 1 get def
9659       /r@y@n table 0 get def
9660    } {
9661       /h@uteur .3 def
9662       /r@y@n .1 def
9663    } ifelse
9664    /A defpoint3d
9665    %%Sommets
9666    /S [0 0 0 A] def
9667    /F [
9668       [0 1]
9669    ] def
9670    S F generesolid
9671    [ A ]
9672    normalvect_to_orthobase
9673    /imK defpoint3d
9674    /imJ defpoint3d
9675    /imI defpoint3d
9676
9677    A norme3d /z exch h@uteur sub def
9678    0 r@y@n h@uteur [1 8] newcone
9679    dup (noir) outputcolors
9680    {0 0 z translatepoint3d} solidtransform
9681    {imI imJ imK transformpoint3d} solidtransform
9682    solidfuz
9683 end
9684 } def
9685
9686 %%%%% ### readsolidfile ###
9687 %% syntaxe : str readsolidfile -> solid
9688 /readsolidfile {
9689 1 dict begin
9690    /str exch def
9691    [str (-sommets.dat) append run]
9692    [str (-faces.dat) append run]
9693    generesolid
9694    dup [str (-couleurs.dat) append run] solidputfcolors
9695    dup [str (-io.dat) append run] solidputinouttable
9696 end
9697 } def
9698
9699 %%%%% ### writesolidfile ###
9700 %% syntaxe : solid str writesolidfile -> -
9701 /writesolidfile {
9702 10 dict begin
9703    /str exch def
9704    /solid exch def
9705    solid issolid not {
9706       (Error : mauvais type d argument dans writesolidfile) ==
9707       quit
9708    } if
9709    str (-sommets.dat) append (w) file /lefichiersommets exch def
9710    str (-faces.dat) append (w) file /lefichierfaces exch def
9711    str (-couleurs.dat) append (w) file /lefichiercouleurs exch def
9712    str (-io.dat) append (w) file /lefichierio exch def
9713
9714    /S solid solidgetsommets def
9715    0 1 S length 3 idiv 1 sub {
9716       /i exch def
9717       solid i solidgetsommet
9718       /z exch def
9719       /y exch def
9720       /x exch def
9721       lefichiersommets x chaine cvs writestring
9722       lefichiersommets 32 write %% espace
9723       lefichiersommets y chaine cvs writestring
9724       lefichiersommets 32 write %% espace
9725       lefichiersommets z chaine cvs writestring
9726       lefichiersommets 10 write %% CR
9727    } for
9728    lefichiersommets closefile
9729
9730    /F solid solidgetfaces def
9731    0 1 F length 1 sub {
9732       /i exch def
9733       /Fi solid i solidgetface def
9734       lefichierfaces 91 write %% [
9735       0 1 Fi length 1 sub {
9736          /j exch def
9737          lefichierfaces Fi j get chaine cvs writestring
9738          lefichierfaces 32 write %% espace
9739       } for
9740       lefichierfaces 93 write %% ]
9741       lefichierfaces 10 write %% CR
9742    } for
9743    lefichierfaces closefile
9744
9745    /C solid solidgetfcolors def
9746    0 1 C length 1 sub {
9747       /i exch def
9748       lefichiercouleurs 40 write %% (
9749       lefichiercouleurs C i get writestring
9750       lefichiercouleurs 41 write %% )
9751       lefichiercouleurs 10 write %% CR
9752    } for
9753    lefichiercouleurs closefile
9754
9755    /IO solid solidgetinouttable def
9756    0 1 3 {
9757       /i exch def
9758       lefichierio IO i get chaine cvs writestring
9759       lefichierio 32 write %% space
9760    } for
9761    lefichierio closefile
9762 end
9763 } def
9764
9765 %%%%% ### writeobjfile ###
9766 %% syntaxe : solid str writeobjfile -> -
9767 /writeobjfile {
9768 10 dict begin
9769    /str exch (.obj) append def
9770    /solid exch def
9771    solid issolid not {
9772       (Erreur : mauvais type d argument dans writeobjfile) ==
9773       quit
9774    } if
9775    /n solid solidnombresommets def
9776    str (w) file /lefichier exch def
9777    0 1 n 1 sub {
9778       /i exch def
9779       solid i solidgetsommet
9780       /z exch def
9781       /y exch def
9782       /x exch def
9783       lefichier (v ) writestring
9784       lefichier x chaine cvs writestring
9785       lefichier 32 write %% espace
9786       lefichier y chaine cvs writestring
9787       lefichier 32 write %% espace
9788       lefichier z chaine cvs writestring
9789       lefichier 10 write %% CR
9790    } for
9791    /n solid solidnombrefaces def
9792    0 1 n 1 sub {
9793       /i exch def
9794       lefichier (f ) writestring
9795       /F solid i solidgetface {1 add} apply def
9796       F {
9797          lefichier exch
9798          chaine cvs writestring
9799          lefichier  32  write %% espace
9800       } apply
9801       lefichier  10  write %% CR
9802    } for
9803    lefichier closefile
9804 end
9805 } def
9806
9807 %%%%% ### writeofffile ###
9808 %% syntaxe : solid str writeobjfile -> -
9809 /writeofffile {
9810 12 dict begin
9811    /str exch (.off) append def
9812    /solid exch def
9813    solid issolid not {
9814       (Erreur : mauvais type d argument dans writeofffile) ==
9815       quit
9816    } if
9817    /n solid solidnombresommets def
9818    /nf solid solidnombrefaces def
9819    str (w) file /lefichier exch def
9820    lefichier (OFF) writestring
9821    lefichier 10 write %% CR
9822    lefichier n chaine cvs writestring
9823    lefichier 32 write %% espace
9824    lefichier nf chaine cvs writestring
9825    lefichier 32 write %% espace
9826    lefichier 0 chaine cvs writestring
9827    lefichier 10 write %% CR
9828    0 1 n 1 sub {
9829       /i exch def
9830       solid i solidgetsommet
9831       /z exch def
9832       /y exch def
9833       /x exch def
9834       lefichier x chaine cvs writestring
9835       lefichier 32 write %% espace
9836       lefichier y chaine cvs writestring
9837       lefichier 32 write %% espace
9838       lefichier z chaine cvs writestring
9839       lefichier 10 write %% CR
9840    } for
9841    0 1 nf 1 sub {
9842       /i exch def
9843       /F solid i solidgetface def
9844       lefichier F length chaine cvs writestring
9845       lefichier 32 write %% espace
9846       F {
9847          lefichier exch
9848          chaine cvs writestring
9849          lefichier  32  write %% espace
9850       } apply
9851       lefichier  10  write %% CR
9852    } for
9853    lefichier closefile
9854 end
9855 } def
9856
9857 %%%%% ### newobjfile ###
9858 /newobjfile {
9859 3 dict begin
9860    /objfilename exch (.obj) append def
9861    /v {} def
9862    /ok true def
9863    /f {
9864        ok {
9865         %% 1ere fois
9866            ] %% ferme les sommets
9867         [ [ %% ouvre les faces
9868         /ok false store
9869        } {
9870         %% les autres fois
9871            ] %% ferme la face
9872         [ %% ouvre la nouvelle
9873        } ifelse
9874    } def
9875    [ 0 0 0 %% sommet fantome pour respecter l'indexation (a partir de l'indice 1)
9876    objfilename run
9877    ]]
9878    /F exch def
9879    /S exch def
9880
9881    S F generesolid
9882 %   dup videsolid
9883 end
9884 } def
9885
9886 %%%%% ### newofffile ###
9887 /newofffile {
9888 3 dict begin
9889    /str 35 string def
9890    /offfilename exch (.off) append def
9891    offfilename (r) file
9892    /offfile exch def
9893    offfile str readline pop pop
9894    offfile str readline pop
9895    numstr2array
9896    dup 0 get /ns exch def
9897    1 get /nf exch def
9898    [ns {
9899       offfile str readline pop numstr2array aload pop
9900 %      3 1 roll
9901    } repeat]
9902    /S exch def
9903    [nf {
9904       [
9905       offfile str readline pop numstr2array
9906       /table exch def
9907       1 1 table length 1 sub {
9908          /i exch def
9909          table i get
9910       } for
9911       ]
9912    } repeat]
9913    /F exch def
9914
9915    S F generesolid
9916 %   dup videsolid
9917 end
9918 } def
9919
9920 %%%%% ### newtube ###
9921  /tub@dernierk1 [1 0 0] def
9922  /tub@dernierk2 [0 1 0] def
9923  /tub@dernierk3 [0 0 1] def
9924
9925 /inittube {
9926 2 dict begin
9927    normalize3d /vect3 defpoint3d
9928    normalize3d /vect2 defpoint3d
9929    normalize3d /vect1 defpoint3d
9930    vect1 norme3d 0 eq {
9931       vect2 vect3 vectprod3d /vect1 defpoint3d
9932    } if
9933    vect2 norme3d 0 eq {
9934       vect3 vect1 vectprod3d /vect2 defpoint3d
9935    } if
9936    vect3 norme3d 0 eq {
9937       vect1 vect2 vectprod3d /vect3 defpoint3d
9938    } if
9939    /tub@dernierk1 [vect1] store
9940    /tub@dernierk2 [vect2] store
9941    /tub@dernierk3 [vect3] store
9942 end
9943 } def
9944
9945 %% syntaxe : tmin tmax (f) array r newtube -> solid
9946 %% array = [K N]
9947 /newtube {
9948 10 dict begin
9949    /table exch def
9950    /K table 0 get def %% nb d etages
9951    /N table 1 get def %% nb de points sur le perimetre
9952    /@r exch def       %% le rayon du tube
9953    /str exch def
9954    /lafonction str cvx def
9955    /laderivee str (') append cvx def
9956 %%   /laderivee2nd str ('') append cvx def
9957    /tmax exch def
9958    /tmin exch def
9959    /pas tmax tmin sub K 1 sub div def
9960
9961    %% definition des sommets
9962    [
9963    /@k 0 def
9964    K {
9965       /a0 tmin @k pas mul add def
9966
9967       %% definition du repere de Frenet (k1, k2, k3) au point f(a)
9968       a0 lafonction /M defpoint3d
9969
9970       str (') append cvlit where {
9971          pop
9972          a0 laderivee normalize3d /k1 defpoint3d
9973 %         pop /avecderiv true def
9974       } {
9975          M a0 pas 100 div add lafonction vecteur3d normalize3d /k1 defpoint3d
9976 %         /avecderiv false
9977       } ifelse
9978
9979       k1 baseplannormal /K3 defpoint3d /K2 defpoint3d
9980 %      a0 laderivee2nd normalize3d /k2 defpoint3d
9981
9982       %% projete orthogonal du dernier rayon sur le plan actuel
9983       %% (normal a la vitesse)
9984       K2 tub@dernierk2 aload pop K2 scalprod3d mulv3d
9985       K3 tub@dernierk2 aload pop K3 scalprod3d mulv3d addv3d /k2 defpoint3d
9986 %      M k1 K2 K3 dessinebase
9987       k1 norme3d 0 eq {
9988          tub@dernierk1 aload pop /k1 defpoint3d
9989       } {
9990          /tub@dernierk1 [k1] store
9991       } ifelse
9992       k2 norme3d 0 eq {
9993          tub@dernierk2 aload pop /k2 defpoint3d
9994       } {
9995          /tub@dernierk2 [k2] store
9996       } ifelse
9997       k1 k2 vectprod3d normalize3d /k3 defpoint3d
9998       k3 norme3d 0 eq {
9999           tub@dernierk3 aload pop /k3 defpoint3d
10000       } {
10001          /tub@dernierk3 [k3] store
10002       } ifelse
10003       k3 k1 vectprod3d normalize3d /k2 defpoint3d
10004 %%      M k1 k2 k3 dessinebase
10005       /tub@dernierk2 [k2] store
10006       /@n 360 N div def %% le pas angulaire
10007       0 @n 360 @n sub {
10008          /@i exch def
10009          M
10010          k2 @i cos @r mul mulv3d addv3d
10011          k3 @i sin @r mul mulv3d addv3d
10012       } for
10013       /@k @k 1 add store
10014    } repeat
10015    ]
10016
10017    dup length 3 idiv /nb exch def
10018    %% definition des faces
10019    [
10020       %% face de depart
10021       [N 1 sub -1 0 {} for]
10022       %% face d arrivee
10023       [nb 1 sub N 1 sub {dup 1 sub} repeat] reverse
10024
10025       %% les etages
10026       /j 0 def
10027       K 1 sub {
10028          0 1 N 1 sub {
10029             /i exch def
10030             [
10031                i                   N j mul add
10032                i 1 add N mod       N j mul add
10033                i 1 add N mod N add N j mul add
10034                i N add             N j mul add
10035             ]
10036          } for
10037          /j j 1 add store
10038       } repeat
10039    ]
10040    generesolid
10041 end
10042 } def
10043
10044 %%%%% ### newcourbe ###
10045 %% syntaxe : a b {f} array newcourbe --> solid
10046 /newcourbe {
10047 10 dict begin
10048    dup xcheck not {
10049       0 get /n exch def
10050    } {
10051       /n 80 def
10052    } ifelse
10053    /l@f@nct exch def
10054    /b exch def
10055    /a exch def
10056    /pas b a sub n 1 sub div def
10057    /S [
10058    0 1 n 1 sub {
10059       /@i exch def
10060       a @i pas mul add
10061       l@f@nct
10062       pstrickactionR3
10063    } for
10064    ] def
10065    /@F [
10066       0 1 n 2 sub {
10067          /@i exch def
10068          [@i @i 1 add]
10069       } for
10070    ] def
10071    S @F generesolid
10072 end
10073 } def
10074
10075 %%%%% ### baseplannormal ###
10076 %% syntaxe : x y z baseplannormal -> x1 y1 z1 x2 y2 z2
10077 /baseplannormal {
10078 5 dict begin
10079    /K defpoint3d
10080    1 0 0 K vectprod3d normalize3d /U defpoint3d
10081    U norme3d 0 eq {
10082       0 1 0 K vectprod3d normalize3d /U defpoint3d
10083    } if
10084    K U vectprod3d normalize3d /V defpoint3d
10085    U V
10086 end
10087 } def
10088
10089 %%%%% ### fin insertion ###
10090
10091 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
10092 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
10093 %%%%                                                    %%%%
10094 %%%%      fin insertion librairie jps                   %%%%
10095 %%%%                                                    %%%%
10096 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
10097 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
10098
10099 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
10100 %%%%          gestion de chaine de caracteres           %%%%
10101 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
10102
10103 /Times-Roman findfont
10104 dup length dict begin
10105    {
10106    1 index /FID ne
10107       {def}
10108       {pop pop}
10109    ifelse
10110    } forall
10111    /Encoding ISOLatin1Encoding def
10112    currentdict
10113 end
10114 /Times-Roman-ISOLatin1 exch definefont pop
10115
10116 /setTimesRoman {
10117    /Times-Roman-ISOLatin1 findfont
10118    fontsize scalefont
10119    setfont
10120 } def
10121
10122 /setTimes {
10123    setTimesRoman
10124 } def
10125
10126 %% syntaxe : string x y cctext
10127 /cctext {
10128 5 dict begin
10129    /y exch def
10130    /x exch def
10131    /str exch def
10132    str stringwidth
10133    /wy exch def
10134    /wx exch def
10135    gsave
10136       x y smoveto
10137       wx -2 div wy -2 div rmoveto
10138       str show
10139    grestore
10140 end
10141 } def
10142
10143 /dbtext {gsave newpath dbtext_ Fill grestore} def
10144 /dctext {gsave newpath dctext_ Fill grestore} def
10145 /dltext {gsave newpath dltext_ Fill grestore} def
10146 /drtext {gsave newpath drtext_ Fill grestore} def
10147
10148 /bbtext {gsave newpath bbtext_ Fill grestore} def
10149 /bctext {gsave newpath bctext_ Fill grestore} def
10150 /bltext {gsave newpath bltext_ Fill grestore} def
10151 /brtext {gsave newpath brtext_ Fill grestore} def
10152
10153 /cbtext {gsave newpath cbtext_ Fill grestore} def
10154 /cctext {gsave newpath cctext_ Fill grestore} def
10155 /cltext {gsave newpath cltext_ Fill grestore} def
10156 /crtext {gsave newpath crtext_ Fill grestore} def
10157
10158 /ubtext {gsave newpath ubtext_ Fill grestore} def
10159 /uctext {gsave newpath uctext_ Fill grestore} def
10160 /ultext {gsave newpath ultext_ Fill grestore} def
10161 /urtext {gsave newpath urtext_ Fill grestore} def
10162
10163
10164 %% syntaxe : str x y show_dim --> str x y llx lly wx wy
10165 %% attention, doit laisser la pile intacte
10166 /show_dim {
10167    3 copy pop pop
10168    newpath
10169       0 0 moveto
10170       true charpath flattenpath pathbbox
10171    closepath
10172    newpath
10173 } def
10174
10175 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
10176 %%%%             procedures pour PSTricks               %%%%
10177 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
10178
10179 %%% les 3 procedures utilisees pour transformer les depots de AlgToPs en nombres
10180 /pstrickactionR3 {
10181 3 dict begin
10182   /len@3 exch def
10183   /len@2 exch def
10184   /len@1 exch def
10185   len@1 exec
10186   len@2 exec
10187   len@3 exec
10188 end
10189 } def
10190
10191 /pstrickactionR2 {
10192    exec exch exec exch
10193 } def
10194
10195 /pstrickactionR {
10196    exec
10197 } def
10198
10199 /gere_pst-deffunction {
10200    counttomark
10201    dup 1 eq {
10202       pop
10203       pstrickactionR
10204       ] aload pop
10205    } {
10206       2 eq {
10207          pstrickactionR2
10208          ] aload pop
10209       } {
10210          pstrickactionR3
10211          ] aload pop
10212       } ifelse
10213    } ifelse
10214 } def
10215
10216 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
10217 %%%%             procedures pour \psSolid               %%%%
10218 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
10219
10220 /all (all) def
10221
10222 /draw {drawsolid} def
10223 /draw* {drawsolid*} def
10224 /draw** {drawsolid**} def
10225 /writeobj {solidfilename writeobjfile} def
10226 /writesolid {solidfilename writesolidfile} def
10227 /writeoff {solidfilename writeofffile} def
10228 /none {pop} def
10229 /vecteur_en_c@urs false def
10230
10231 /gere_pstricks_color_inout {
10232    gsave
10233       dup  [fillincolor] (setrgbcolor) astr2str
10234          [fillcolor] (setrgbcolor) astr2str inoutputcolors
10235    grestore
10236 } def
10237
10238 /gere_pstricks_color_out {
10239    gsave
10240       dup  [fillcolor] (setrgbcolor) astr2str outputcolors
10241    grestore
10242 } def
10243
10244 /gere_pstfont {
10245    fontsize mul setfontsize
10246    %setTimes
10247    PSfont dup /Symbol ne isolatin and {
10248       /ISO-Font ReEncode /ISO-Font
10249    } if
10250    findfont fontsize scalefont setfont
10251 } def
10252
10253 /gere_pstricks_opt {
10254 %   /CourbeR2 {CourbeR2+} def
10255    1 gere_pstfont
10256    linecolor
10257    linestyle
10258    solidlinewidth setlinewidth
10259    solidtrunc length 0 ne {
10260       solidtrunc 0 get isstring {
10261          dup trunccoeff solidtronque
10262       } {
10263          dup solidtrunc trunccoeff solidtronque
10264       } ifelse
10265    } if
10266    solidgeode {
10267       1 newgeode
10268    } if
10269    soliddualreg {
10270       dualpolyedreregulier
10271    } if
10272    chanfrein {
10273       dup chanfreincoeff solidchanfreine
10274    } if
10275    RotX 0 ne RotY 0 ne or RotZ 0 ne or {
10276       {RotX RotY RotZ rotateOpoint3d} solidtransform
10277    } if
10278    CX 0 ne CY 0 ne or CZ 0 ne or {
10279       {CX CY CZ translatepoint3d} solidtransform
10280    } if
10281    plansection length 0 gt {
10282       0 1 plansection length 1 sub {
10283          /i exch def
10284          plansection i get solidplansection
10285          dup 0 solidrmface
10286       } for
10287    } if
10288    /rmfaces rmfaces bubblesort reverse store
10289    0 1 rmfaces length 1 sub {
10290       /i exch def
10291       dup rmfaces i get solidrmface
10292    } for
10293    tx@Dict /pst-transformoption known {
10294       dup {pst-transformoption} solidtransform
10295    } if
10296    solidaffinage length 0 ne {
10297       %% si on affine, il faut colorier avant
10298       activationgestioncouleurs {
10299          gere_pstricks_color_out
10300       } if
10301       solidaffinage 0 get isstring {
10302          dup affinagecoeff
10303          /solidfcolor where {
10304             pop
10305             solidfcolor
10306          } if
10307          affinagerm solidaffine
10308       } {
10309          dup affinagecoeff solidaffinage
10310          /solidfcolor where {
10311             pop
10312             solidfcolor
10313          } if
10314          affinagerm solidaffine
10315       } ifelse
10316       %% et il faut evider et coloriier l'interieur si necessaire
10317       solidhollow {
10318          dup videsolid
10319          activationgestioncouleurs {
10320             gsave
10321                dup  [fillincolor] (setrgbcolor) astr2str inputcolors
10322             grestore
10323          } if
10324       } if
10325       /activationgestioncouleurs false def
10326    } if
10327    tx@Dict /plansepare known {
10328       plansepare solidplansepare
10329       tx@Dict /plansepare undef
10330       tx@Dict /solidname known {
10331          solidname (1) append cvlit exch def
10332          dup solidname (0) append cvlit exch def
10333          %%
10334          solidname (1) append cvx exec
10335          solidhollow {
10336             dup videsolid
10337          } if
10338          activationgestioncouleurs {
10339             dup solidwithinfaces {
10340                gere_pstricks_color_inout
10341             } {
10342                gere_pstricks_color_out
10343             } ifelse
10344          } if
10345          solidinouthue length 0 gt {
10346             dup solidinouthue solidputinouthuecolors
10347          } {
10348             solidhue length 0 gt {
10349                dup solidhue solidputhuecolors
10350             } if
10351             solidinhue length 0 gt {
10352                dup solidinhue solidputinhuecolors
10353             } if
10354          } ifelse
10355          pop
10356          tx@Dict /solidname undef
10357       } {
10358          /solid1 exch def
10359          /solid2 exch def
10360       } ifelse
10361    } if
10362    solidhollow {
10363       dup videsolid
10364    } if
10365    activationgestioncouleurs {
10366       zcolor length 0 ne {
10367          dup zcolor tablez solidcolorz
10368       } {
10369          dup solidwithinfaces {
10370             gere_pstricks_color_inout
10371          } {
10372             gere_pstricks_color_out
10373          } ifelse
10374          solidinouthue length 0 gt {
10375             dup solidinouthue solidputinouthuecolors
10376          } {
10377             solidhue length 0 gt {
10378                dup solidhue solidputhuecolors
10379             } if
10380             solidinhue length 0 gt {
10381                dup solidinhue solidputinhuecolors
10382             } if
10383          } ifelse
10384       } ifelse
10385    } {
10386       /activationgestioncouleurs true def
10387    } ifelse
10388
10389    0 1 fcol length 2 idiv 1 sub {
10390       /i exch def
10391       dup fcol 2 i mul get fcol 2 i mul 1 add get solidputfcolor
10392    } for
10393    vecteur_en_c@urs not {
10394       /lightsrc where {pop solidlightOn} if
10395    } {
10396       /vecteur_en_c@urs false def
10397    } ifelse
10398    dup action cvx exec
10399    noir
10400    solidnumf length 0 ne {
10401       solidnumf 0 get isstring {
10402          dup projectionsifacevisible solidnumfaces
10403       } {
10404          dup solidnumf projectionsifacevisible solidnumfaces
10405       } ifelse
10406    } if
10407    solidshow length 0 ne {
10408       solidshow 0 get isstring {
10409          dup solidshowsommets
10410       } {
10411          dup solidshow solidshowsommets
10412       } ifelse
10413    } if
10414    solidnum length 0 ne {
10415       solidnum 0 get isstring {
10416          .8 gere_pstfont
10417          dup solidnumsommets
10418       } {
10419          dup solidnum solidnumsommets
10420       } ifelse
10421    } {
10422       %% pop
10423    } ifelse
10424    tx@Dict /solidname known {
10425       solidname cvlit exch bind def
10426       tx@Dict /solidname undef
10427    } {
10428       pop
10429    } ifelse
10430 } def
10431
10432 /pst-octahedron {
10433    a newoctaedre
10434    gere_pstricks_opt
10435 } def
10436
10437 /pst-dodecahedron {
10438    a newdodecaedre
10439    gere_pstricks_opt
10440 } def
10441
10442 /pst-icosahedron {
10443    a newicosaedre
10444    gere_pstricks_opt
10445 } def
10446
10447 /pst-cube {
10448    a
10449    ngrid length 1 eq {
10450       ngrid
10451    } {
10452       {Mode}
10453    } ifelse
10454    newcube
10455 %%    solidhollow {
10456 %%       dup videsolid
10457 %%    } if
10458    gere_pstricks_opt
10459 } def
10460
10461 /pst-parallelepiped {
10462    a b c
10463    newparallelepiped
10464    gere_pstricks_opt
10465 } def
10466
10467 /pst-tetrahedron {
10468    r newtetraedre
10469    gere_pstricks_opt
10470 } def
10471
10472 /pst-tore {
10473    r0 r1
10474    ngrid length 2 eq {
10475       ngrid
10476    } {
10477       {Mode}
10478    } ifelse
10479    newtore
10480    gere_pstricks_opt
10481 } def
10482
10483 /pst-sphere {
10484    % rayon
10485    % mode
10486   %   r {Mode} newsphere
10487    r
10488    ngrid length 2 eq {
10489       ngrid
10490    } {
10491       {Mode}
10492    } ifelse
10493    newsphere
10494    gere_pstricks_opt
10495 } def
10496 %
10497 /pst-cylindre {
10498    /save-cylinderhollow solidhollow def
10499    tx@Dict /function known {
10500       range aload pop function cvx {axe} h ngrid newcylindre
10501       tx@Dict /function undef
10502       /solidhollow true def
10503    } {
10504       % rayon
10505       % mode
10506       0 r h
10507       ngrid length 2 eq {
10508          ngrid
10509       } {
10510          {Mode}
10511       } ifelse
10512       newcylindre
10513       solidhollow {
10514          dup creusesolid
10515       } if
10516    } ifelse
10517    gere_pstricks_opt
10518    /solidhollow save-cylinderhollow store
10519 } def
10520 %
10521 /pst-cylindrecreux {
10522    % rayon
10523    % mode
10524    0 r h
10525    ngrid length 2 eq {
10526       ngrid
10527    } {
10528       {Mode}
10529    } ifelse
10530    newcylindre
10531    dup creusesolid
10532    gere_pstricks_opt
10533 } def
10534
10535 /pst-cone {
10536    /save-conehollow solidhollow def
10537    tx@Dict /function known {
10538       range aload pop function cvx {origin} ngrid newcone
10539       tx@Dict /function undef
10540       /solidhollow true def
10541    } {
10542       % rayon
10543       % mode
10544       0 r h
10545       ngrid length 2 eq {
10546          ngrid
10547       } {
10548          {Mode}
10549       } ifelse
10550       solidhollow {
10551          newconecreux
10552       } {
10553          newcone
10554       } ifelse
10555    } ifelse
10556    gere_pstricks_opt
10557    /solidhollow save-conehollow store
10558 } def
10559
10560 /pst-tronccone {
10561    % rayon
10562    % mode
10563    0 r0 h r1
10564    ngrid length 2 eq {
10565       ngrid
10566    } {
10567       {Mode}
10568    } ifelse
10569    solidhollow {
10570       newtroncconecreux
10571    } {
10572       newtronccone
10573    } ifelse
10574    gere_pstricks_opt
10575 } def
10576
10577 /pst-troncconecreux {
10578    % rayon
10579    % mode
10580    0 r0 h r1
10581    ngrid length 2 eq {
10582       ngrid
10583    } {
10584       {Mode}
10585    } ifelse
10586    newtroncconecreux
10587    gere_pstricks_opt
10588 } def
10589
10590 /pst-conecreux {
10591    % rayon
10592    % mode
10593    0 r h
10594    ngrid length 2 eq {
10595       ngrid
10596    } {
10597       {Mode}
10598    } ifelse
10599    newconecreux
10600    gere_pstricks_opt
10601 } def
10602
10603 /pst-anneau {
10604    [ section ]
10605    ngrid length 1 ge {
10606       [ngrid 0 get]
10607    } {
10608       [24]
10609    } ifelse
10610    newanneau
10611    gere_pstricks_opt
10612 } def
10613
10614
10615 /pst-prisme {
10616    % tableau des points de la base
10617    % h hauteur du prisme
10618    % axe : vecteur direction de l axe
10619    base decal rollparray
10620    0 h axe
10621    ngrid length 1 ge {
10622       [ngrid 0 get]
10623    } if
10624    newprisme
10625    solidhollow {
10626       dup creusesolid
10627    } if
10628    gere_pstricks_opt
10629 } def
10630
10631 /pst-prismecreux {
10632    % tableau des points de la base
10633    % h hauteur du prisme
10634    % axe : vecteur direction de l axe
10635    base
10636    0 h axe
10637    ngrid length 1 ge {
10638       [ngrid 0 get]
10639    } if
10640    newprisme
10641    dup creusesolid
10642    gere_pstricks_opt
10643 } def
10644
10645 /pst-grille {
10646    base aload pop
10647    ngrid length 2 ge {
10648       [ngrid 0 get ngrid 1 get]
10649    } {
10650       ngrid length 1 eq {
10651          [ngrid 0 get dup]
10652       } if
10653    } ifelse
10654    newgrille
10655    gere_pstricks_opt
10656 } def
10657
10658 %% syntaxe : array N h u newruban -> solid d axe (O, u),
10659 /pst-ruban {
10660    % tableau des points de la base
10661    % h hauteur du prisme
10662    % axe : vecteur direction de l axe
10663    base
10664    h axe
10665    ngrid length 1 ge {
10666       [ngrid 0 get]
10667    } if
10668    newruban
10669    gere_pstricks_opt
10670 } def
10671
10672 %% syntaxe : r phi option newcalottesphere -> solid
10673 /pst-calottesphere {
10674    % rayon
10675    % mode
10676    % r phi theta option newcalottesphere
10677    r
10678    phi theta
10679    ngrid length 2 eq {
10680       ngrid
10681    } {
10682       {Mode}
10683    } ifelse
10684    solidhollow {
10685       newcalottespherecreuse
10686    } {
10687       newcalottesphere
10688    } ifelse
10689    gere_pstricks_opt
10690 } def
10691
10692 %% syntaxe : r phi option newcalottesphere -> solid
10693 /pst-calottespherecreuse {
10694    % rayon
10695    % mode
10696    % r phi theta option newcalottespherecreuse
10697    r
10698    phi theta
10699    ngrid length 2 eq {
10700       ngrid
10701    } {
10702       {Mode}
10703    } ifelse
10704    newcalottespherecreuse
10705    gere_pstricks_opt
10706 } def
10707
10708 /pointtest{2 2 2} def
10709
10710 /pst-face {
10711    % tableau des points de la base
10712    % h hauteur du prisme
10713    % axe : vecteur direction de l axe
10714    base
10715    solidbiface {
10716       newbiface
10717    } {
10718       newmonoface
10719    } ifelse
10720    gere_pstricks_opt
10721 } def
10722
10723 /pst-Surface {
10724    base
10725    base aload pop
10726    ngrid length 2 ge {
10727       [ngrid 0 get ngrid 1 get]
10728    } {
10729       ngrid length 1 eq {
10730          [ngrid 0 get dup]
10731       } ifelse
10732    } ifelse
10733    {f} newsurface
10734    solidbiface {
10735       dup videsolid
10736    } if
10737    gere_pstricks_opt
10738 } def
10739
10740 /pst-Surface* {
10741    r
10742    ngrid length 2 ge {
10743       [ngrid 0 get ngrid 1 get]
10744    } {
10745       ngrid length 1 eq {
10746          [ngrid 0 get dup]
10747       } ifelse
10748    } ifelse
10749    {f} newsurface*
10750    solidbiface {
10751       dup videsolid
10752    } if
10753    gere_pstricks_opt
10754 } def
10755
10756 /pst-surface {
10757    base
10758    base aload pop
10759    ngrid length 2 ge {
10760       [ngrid 0 get ngrid 1 get]
10761    } {
10762       ngrid length 1 eq {
10763          [ngrid 0 get dup]
10764       } ifelse
10765    } ifelse
10766    { function cvx exec } newsurface
10767    solidbiface {
10768       dup videsolid
10769    } if
10770    gere_pstricks_opt
10771 } def
10772
10773 /pst-polygoneregulier {
10774    r ngrid 0 get
10775    newpolreg
10776    solidbiface {
10777    } {
10778       dup 1 solidrmface
10779    } ifelse
10780    gere_pstricks_opt
10781 } def
10782
10783 /pst-fusion {
10784 1 dict begin
10785    /activationgestioncouleurs false def
10786    /n base length def
10787    base aload pop n 1 sub {solidfuz} repeat
10788    gere_pstricks_opt
10789 end
10790 } def
10791
10792 /pst-new {
10793    sommets faces
10794    generesolid
10795 %%    solidhollow {
10796 %%       dup videsolid
10797 %%    } if
10798    gere_pstricks_opt
10799 } def
10800
10801 /pst-courbe {
10802    solidlinewidth setlinewidth
10803    r 0 eq {
10804       range aload pop function cvx [resolution] newcourbe
10805       gere_pstricks_opt
10806    } {
10807       range aload pop function r
10808       ngrid length 2 lt {
10809          [300 4]
10810       } {
10811          ngrid
10812       } ifelse
10813       newtube
10814       gere_pstricks_opt %% r function [36 12] newtube
10815    } ifelse
10816 } def
10817 %
10818 /pst-surfaceparametree {
10819    base aload pop
10820    ngrid length 2 ge {
10821       [ngrid 0 get ngrid 1 get]
10822    } {
10823       ngrid length 1 eq {
10824          [ngrid 0 get dup]
10825       } if
10826    } ifelse
10827    { function cvx exec } newsurfaceparametree
10828    dup videsolid
10829    gere_pstricks_opt
10830    tx@Dict /function undef
10831 } def
10832 %
10833 /pst-surface* {
10834    r
10835    ngrid length 2 ge {
10836       [ngrid 0 get ngrid 1 get]
10837    } {
10838       ngrid length 1 eq {
10839          [ngrid 0 get dup]
10840       } if
10841    } ifelse
10842    { function cvx exec } newsurface*
10843    dup videsolid
10844    gere_pstricks_opt
10845 } def
10846
10847 /pst-vecteur {
10848 gsave
10849    /activationgestioncouleurs false def
10850    /vecteur_en_c@urs true def
10851    solidlinewidth setlinewidth
10852    2 setlinejoin
10853    1 setlinecap
10854    linecolor
10855    linestyle
10856    tx@Dict /solidname known {
10857       args definition cvx exec
10858       solidname cvlit defpoint3d
10859       tx@Dict /solidname undef
10860    } if
10861    args definition cvx exec newvecteur
10862    dup
10863    gsave
10864       [linecolor currentrgbcolor] ( ) astr2str (setrgbcolor) append
10865       outputcolors
10866    grestore
10867    gere_pstricks_opt
10868 grestore
10869 } def
10870
10871 %/pst-vect- {} def
10872 %/pst-vect-2points {vecteur3d} def
10873 /pst-line {
10874    gsave
10875       linestyle
10876       linecolor
10877       [args] ligne3d
10878    grestore
10879 } def
10880
10881 /pst-objfile {
10882    solidfilename newobjfile
10883    gere_pstricks_opt
10884 } def
10885
10886 /pst-offfile {
10887    solidfilename newofffile
10888    gere_pstricks_opt
10889 } def
10890
10891 /pst-datfile {
10892    solidfilename readsolidfile
10893 %   /activationgestioncouleurs false def
10894    gere_pstricks_opt
10895 } def
10896
10897 /pst-plantype {
10898 %   args definition
10899    args (pst-plan-) definition append cvx exec
10900    dup phi rotateplan
10901    base length 4 eq {
10902       dup base planputrange
10903    } if
10904    origin eqpl@n pointeqplan 0 eq {
10905       dup origin planputorigine
10906    } if
10907    ngrid length 0 ne {
10908       dup ngrid planputngrid
10909    } if
10910    tx@Dict /solidname known {
10911       solidname cvlit exch bind def
10912       tx@Dict /solidname undef
10913    } {
10914       pop
10915    } ifelse
10916 } def
10917 /pst-plan- {pst-plan-plantype} def
10918
10919 %x0 y0 z0 [normalvect] norm2plan
10920 /pst-plan-plantype {
10921    dup plan2eq /eqpl@n exch def
10922    /plan-@k true def
10923 } def
10924
10925 /pst-plan {
10926 %   args definition
10927    args (pst-plan-) definition append cvx exec
10928    /pl@n-en-cours true def
10929    definition length 0 ne {
10930 %   plan-@k not {
10931       dup
10932       base 0 get base 1 get lt
10933       base 2 get base 3 get lt and {
10934          base
10935       } {
10936          [-3 3 -2 2] %pop base %aload pop boum
10937       } ifelse
10938       planputrange
10939       origin eqpl@n pointeqplan 0 eq {
10940          dup origin planputorigine
10941       } if
10942       CX isreal
10943       CX 0 eq and
10944       CY isreal and
10945       CY 0 eq and
10946       CZ isreal and
10947       CZ 0 eq and not {
10948          dup CX CY CZ planputorigine
10949       } if
10950       /CX 0. def
10951       /CY 0. def
10952       /CZ 0. def
10953       ngrid length 0 ne {
10954          dup ngrid planputngrid
10955       } if
10956    } if
10957 %   dup RotX RotY RotZ rotateOplan
10958    dup phi rotateplan
10959    /l@pl@n exch def
10960    tx@Dict /solidname known {
10961       l@pl@n solidname cvlit exch bind def
10962       /solidname solidname (_s) append store
10963    } if
10964    l@pl@n newplan
10965    gere_pstricks_opt
10966    /pl@n-en-cours false def
10967 %   action ==
10968 %   noir
10969    l@pl@n RotX RotY RotZ rotateOplan
10970 %   l@pl@n CX CY CZ plantranslate
10971 %   fontsize setfontsize
10972 %   setTimes
10973    1 gere_pstfont
10974    solidplanmarks {l@pl@n projectionsifacevisible planmarks} if
10975    solidplangrid {linecolor l@pl@n projectionsifacevisible planquadrillage} if
10976    solidshowbase {l@pl@n projectionsifacevisible planshowbase} if
10977    solidshowbase3d {l@pl@n projectionsifacevisible planshowbase3d} if
10978 } def
10979
10980
10981 /pst-plan-normalpoint {
10982    /plan-@k false def
10983    norm2plan
10984    dup plan2eq /eqpl@n exch def
10985 } def
10986
10987 /pst-plan-equation {
10988    /plan-@k false def
10989    dup isarray {
10990       dup /eqpl@n exch def
10991    } {
10992       2 copy pop /eqpl@n exch def
10993    } ifelse
10994    eq2plan
10995 } def
10996
10997 /pst-plan-solidface {
10998    /plan-@k false def
10999    solidface2plan
11000    CX isreal
11001    CX 0 eq and
11002    CY isreal and
11003    CY 0 eq and
11004    CZ isreal and
11005    CZ 0 eq and not {
11006       dup CX CY CZ planputorigine
11007    } if
11008
11009 %   dup plangetrange aload pop boum
11010 %   dup origin planputorigine
11011    dup plan2eq /eqpl@n exch def
11012 } def
11013
11014 /pst-geode {
11015    ngrid aload pop newgeode
11016    gere_pstricks_opt
11017 } def
11018
11019 /pst-load {
11020    solidloadname
11021 %   /activationgestioncouleurs false def
11022    gere_pstricks_opt
11023 } def
11024
11025 /pst-point {
11026 gsave
11027    linecolor
11028    1 gere_pstfont
11029    action (none) eqstring not {
11030       args definition cvx exec point3d
11031    } if
11032    texte args definition cvx exec pos (text3d) append cvx exec
11033    tx@Dict /solidname known {
11034       args definition cvx exec
11035       solidname cvlit defpoint3d
11036       tx@Dict /solidname undef
11037    } if
11038 grestore
11039 } def
11040
11041 %% syntaxe : alpha beta r h newpie --> solid
11042 /pst-pie {
11043    phi theta r h
11044    ngrid length 2 ge {
11045       [ngrid 0 get ngrid 1 get]
11046    } if
11047    newpie
11048    gere_pstricks_opt
11049 } def
11050
11051 /pst-trigospherique {
11052 3 dict begin
11053 gsave
11054    solidlinewidth setlinewidth
11055    linecolor
11056    linestyle
11057    args definition cvx exec
11058 grestore
11059 end
11060 } def
11061
11062 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
11063 %%%%         procedures pour \psProjection              %%%%
11064 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
11065
11066 /gere_pstricks_proj_opt {
11067       /planprojpst where {
11068          pop
11069          planprojpst projectionsifacevisible projpath
11070 %        /planprojpst where pop /planprojpst undef
11071       } {
11072          /solidprojname where {
11073             /solidprojname get noface phi
11074             xorigine 0 eq
11075             yorigine 0 eq and
11076             zorigine 0 eq and
11077             xorigine isinteger not and
11078             yorigine isinteger not and
11079             yorigine isinteger not and {
11080             } {
11081                [xorigine yorigine zorigine] (                 ) astr2str
11082             } ifelse
11083             projectionsifacevisible solidprojpath
11084          } {
11085             xorigine yorigine zorigine [ normale ] projectionsifacevisible planprojpath
11086          } ifelse
11087       } ifelse
11088 } def
11089
11090 /proj-pst-chemin {
11091    solidlinewidth setlinewidth
11092    1 dict begin
11093    newpath
11094       /cercle {cercle_} def
11095       path
11096       linecolor
11097       gere_pstricks_proj_opt
11098    end
11099 } def
11100
11101 /proj-pst-courbeR2 {
11102    l@pl@n plangetrange aload pop
11103    setyrange setxrange
11104    newpath
11105       xmin ymin l@pl@n pointplan smoveto
11106       xmin ymax l@pl@n pointplan slineto
11107       xmax ymax l@pl@n pointplan slineto
11108       xmax ymin l@pl@n pointplan slineto
11109       xmin ymin l@pl@n pointplan slineto
11110       planprojpst projpath
11111    clip
11112    solidlinewidth setlinewidth
11113    newpath
11114       linecolor
11115       range aload pop { function cvx exec } CourbeR2_
11116       gere_pstricks_proj_opt
11117 } def
11118
11119 /proj-pst-courbe {
11120    l@pl@n plangetrange aload pop
11121    setyrange setxrange
11122    newpath
11123       xmin ymin l@pl@n pointplan smoveto
11124       xmin ymax l@pl@n pointplan slineto
11125       xmax ymax l@pl@n pointplan slineto
11126       xmax ymin l@pl@n pointplan slineto
11127       xmin ymin l@pl@n pointplan slineto
11128       planprojpst projpath
11129    clip
11130    solidlinewidth setlinewidth
11131    newpath
11132       linecolor
11133       range aload pop {} { function cvx exec } Courbeparam_
11134       gere_pstricks_proj_opt
11135 } def
11136
11137 /proj-pst-point {
11138    [proj-args] length 0 eq {
11139       xorigine yorigine /proj-args defpoint
11140    } if
11141    /projname where {
11142       pop
11143       [proj-args proj-definition cvx exec]
11144       dup 0 getp projname cvlit defpoint
11145       dup length 2 gt {
11146          1 getp projname (0) append cvlit defpoint
11147       } if
11148       /projname where pop /projname undef
11149    } if
11150    proj-action (none) eqstring not {
11151       solidlinewidth setlinewidth
11152       linecolor
11153       [proj-args proj-definition cvx exec] 0 getp point_
11154       gere_pstricks_proj_opt
11155       Stroke
11156    } if
11157 %   1 1 0 0 1 1 Diamond
11158    texte length 0 gt {
11159       proj-fontsize setfontsize
11160       %setTimes
11161       solidlinewidth setlinewidth
11162       newpath
11163       linecolor
11164       texte [proj-args proj-definition cvx exec 0 0 phi neg rotatepoint] 0 getp
11165       pos (text_) append cvx exec
11166 %%    /planprojpst where {
11167 %%       planprojpst dupplan dup phi rotateplan /planprojpst exch def
11168 %%       pop
11169 %%       xorigine yorigine
11170 %%       0 0 phi neg rotatepoint
11171 %%    } {
11172 %%       0 0
11173 %%    } ifelse
11174       %gere_pstricks_proj_opt
11175       planprojpst dupplan dup phi rotateplan projectionsifacevisible projpath
11176       Fill
11177    } if
11178 } def
11179
11180 /proj-pst-vecteur {
11181    proj-action (none) eqstring not {
11182       planprojpst bprojscene
11183       solidlinewidth setlinewidth
11184       linestyle
11185       linecolor
11186       xorigine yorigine 2 copy proj-args proj-definition cvx exec addv drawvecteur
11187       eprojscene
11188    } if
11189    /projname where {
11190       pop
11191       proj-args proj-definition cvx exec projname cvlit defpoint
11192       /projname where pop /projname undef
11193    } if
11194 } def
11195
11196 /proj-pst-droite {
11197    proj-action (none) eqstring not {
11198       l@pl@n plangetrange aload pop
11199       setyrange setxrange
11200 %%       newpath
11201 %%          xmin ymin l@pl@n pointplan smoveto
11202 %%          xmin ymax l@pl@n pointplan slineto
11203 %%          xmax ymax l@pl@n pointplan slineto
11204 %%          xmax ymin l@pl@n pointplan slineto
11205 %%          xmin ymin l@pl@n pointplan smoveto
11206 %%       planprojpst projpath
11207 %%       clip
11208       planprojpst bprojscene
11209       solidlinewidth setlinewidth
11210       linestyle
11211       linecolor
11212       proj-args proj-definition cvx exec droite
11213       eprojscene
11214    } if
11215    /projname where {
11216       pop
11217       proj-args proj-definition cvx exec projname cvlit defdroite
11218       /projname where pop /projname undef
11219    } if
11220 } def
11221
11222 /proj-pst-polygone {
11223    proj-action (none) eqstring not {
11224       l@pl@n plangetrange aload pop
11225       setyrange setxrange
11226       newpath
11227          xmin ymin l@pl@n pointplan smoveto
11228          xmin ymax l@pl@n pointplan slineto
11229          xmax ymax l@pl@n pointplan slineto
11230          xmax ymin l@pl@n pointplan slineto
11231          xmin ymin l@pl@n pointplan slineto
11232          planprojpst projpath
11233       clip
11234       solidlinewidth setlinewidth
11235       linestyle
11236       linecolor
11237       proj-definition length 0 eq {
11238          [proj-args]
11239       } {
11240          proj-args
11241       } ifelse
11242       proj-definition cvx exec polygone_
11243       planprojpst projectionsifacevisible projpath
11244    } if
11245    /projname where {
11246       pop
11247       proj-definition length 0 eq {
11248          [proj-args]
11249       } {
11250          proj-args
11251       } ifelse
11252       proj-definition cvx exec projname cvlit exch def
11253       /projname where pop /projname undef
11254    } if
11255 } def
11256
11257 /proj-pst-cercle {
11258    /projname where {
11259       pop
11260       proj-args proj-definition cvx exec projname cvlit defcercle
11261       /projname where pop /projname undef
11262    } if
11263    proj-action (none) eqstring not {
11264       l@pl@n plangetrange aload pop
11265       setyrange setxrange
11266 %%       newpath
11267 %%          xmin ymin l@pl@n pointplan smoveto
11268 %%          xmin ymax l@pl@n pointplan slineto
11269 %%          xmax ymax l@pl@n pointplan slineto
11270 %%          xmax ymin l@pl@n pointplan slineto
11271 %%          xmin ymin l@pl@n pointplan slineto
11272 %%       planprojpst projpath
11273 %%       clip
11274       solidlinewidth setlinewidth
11275       linestyle
11276       linecolor
11277       newpath
11278       range aload pop proj-args
11279       proj-definition cvx exec Cercle_
11280       planprojpst projectionsifacevisible projpath
11281    } if
11282 } def
11283
11284 /proj-pst-line {
11285    proj-action (none) eqstring not {
11286       l@pl@n plangetrange aload pop
11287       setyrange setxrange
11288 %%       newpath
11289 %%          xmin ymin l@pl@n pointplan smoveto
11290 %%          xmin ymax l@pl@n pointplan slineto
11291 %%          xmax ymax l@pl@n pointplan slineto
11292 %%          xmax ymin l@pl@n pointplan slineto
11293 %%          xmin ymin l@pl@n pointplan slineto
11294 %%          planprojpst projpath
11295 %%       clip
11296       planprojpst bprojscene
11297       solidlinewidth setlinewidth
11298       linestyle
11299       linecolor
11300       proj-definition length 0 eq {
11301          [proj-args]
11302       } {
11303          proj-args
11304       } ifelse
11305       proj-definition cvx exec ligne
11306       eprojscene
11307    } if
11308    /projname where {
11309       pop
11310       proj-definition length 0 eq {
11311          [proj-args]
11312       } {
11313          proj-args
11314       } ifelse
11315       proj-definition cvx exec projname cvlit exch def
11316       /projname where pop /projname undef
11317    } if
11318 } def
11319
11320 /proj-pst-rightangle {
11321    proj-action (none) eqstring not {
11322       planprojpst bprojscene
11323       solidlinewidth setlinewidth
11324       linestyle
11325       linecolor
11326       proj-args proj-definition cvx exec angledroit
11327       eprojscene
11328    } if
11329 } def
11330
11331 /proj-pst-texte {
11332 2 dict begin
11333    proj-fontsize setfontsize
11334    %setTimes
11335    1 gere_pstfont
11336    solidlinewidth setlinewidth
11337    newpath
11338    linecolor
11339    texte
11340    /planprojpst where {
11341       planprojpst dupplan dup phi rotateplan /planprojpst exch def
11342       pop
11343       xorigine yorigine
11344       0 0 phi neg rotatepoint
11345    } {
11346       0 0
11347    } ifelse
11348    pos (text_) append cvx exec
11349    gere_pstricks_proj_opt
11350 Fill
11351 end
11352 } def
11353
11354 % END solides.pro