solides.pro

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