extra/gml/b-rep/b-rep.factor

   1 ! Copyright (C) 2010 Slava Pestov.
   2 USING: accessors euler.b-rep euler.operators
   3 game.models.half-edge gml.macros gml.printer gml.runtime
   4 gml.types io io.styles kernel namespaces ;
   5 FROM: alien.c-types => >c-bool c-bool> ;
   6 IN: gml.b-rep
   7
   8 LOG-GML: makeVEFS ( p1 p2 -- edge ) make-vefs ;
   9
  10 LOG-GML: makeEV ( e0 e1 p -- edge ) make-ev ;
  11
  12 LOG-GML: makeEVone ( e0 p -- edge ) dupd make-ev ;
  13
  14 LOG-GML: makeEF ( e1 e2 -- edge ) make-ef ;
  15
  16 LOG-GML: makeEkillR ( edge-ring edge-face -- edge ) make-e-kill-r ;
  17
  18 LOG-GML: makeFkillRH ( edge-ring -- ) make-f-kill-rh ;
  19
  20 LOG-GML: killVEFS ( edge -- ) kill-vefs ;
  21
  22 LOG-GML: killEV ( edge -- ) kill-ev ;
  23
  24 LOG-GML: killEF ( edge -- ) kill-ef ;
  25
  26 LOG-GML: killEmakeR ( edge -- edge-ring ) kill-e-make-r ;
  27
  28 LOG-GML: killFmakeRH ( face-edge base-face-edge -- ) kill-f-make-rh ;
  29
  30 GML: moveV ( edge point -- ) move-v ;
  31
  32 GML: moveE ( edge offset -- ) move-e ;
  33
  34 GML: moveF ( edge offset -- ) move-f ;
  35
  36 GML: vertexCW ( e0 -- e1 ) vertex-cw ;
  37
  38 GML: vertexCCW ( e0 -- e1 ) vertex-ccw ;
  39
  40 GML: faceCW ( e0 -- e1 ) face-cw ;
  41
  42 GML: faceCCW ( e0 -- e1 ) face-ccw ;
  43
  44 GML: baseface ( e0 -- e1 ) base-face>> ;
  45
  46 GML: nextring ( e0 -- e1 ) dup next-ring>> [ nip ] [ base-face>> ] if* ;
  47
  48 GML: facenormal ( e0 -- n ) face-normal ;
  49 GML: faceplanedist ( e0 -- d ) face-plane-dist ;
  50 GML: faceplane  ( e0 -- n d ) face-plane ;
  51
  52 GML: facemidpoint ( e0 -- v ) face-midpoint ;
  53
  54 GML: facedegree ( e0 -- n ) face-sides ;
  55
  56 GML: edgemate ( e0 -- e1 ) opposite-edge>> ;
  57 GML: edgeflip ( e0 -- e1 ) opposite-edge>> ;
  58
  59 GML: edgedirection ( e0 -- v ) edge-direction ;
  60
  61 GML: vertexpos ( e0 -- p ) vertex-pos ;
  62
  63 GML: valence ( e0 -- n ) vertex-valence ;
  64
  65 GML: sameEdge ( e0 e1 -- ? ) same-edge? >true ;
  66
  67 GML: sameFace ( e0 e1 -- ? ) same-face? >true ;
  68
  69 GML: sameVertex ( e0 e1 -- ? ) incident? >true ;
  70
  71 GML: isBaseface ( e -- ? ) face>> base-face? ;
  72
  73 GML: sharpE ( e sharp -- ) c-bool> sharp-e ;
  74
  75 GML: sharpF ( e sharp -- ) c-bool> sharp-f ;
  76
  77 GML: sharpV ( e sharp -- ) c-bool> sharp-v ;
  78
  79 GML: issharp ( e -- sharp ) sharpness>> >c-bool ;
  80
  81 GML: isValidEdge ( e -- ? ) b-rep get is-valid-edge? ;
  82
  83 GML: materialF ( e material -- ) material-f ;
  84
  85 GML: setcurrentmaterial ( material -- ) drop ;
  86 GML: getcurrentmaterial ( -- material ) "none" name ;
  87 GML: pushcurrentmaterial ( material -- ) drop ;
  88 GML: popcurrentmaterial ( -- material ) "none" name ;
  89 GML: getmaterialnames ( -- [material] ) { } ;
  90 GML: setfacematerial ( e material -- ) material-f ;
  91 GML: getfacematerial ( e -- material ) drop "none" name ;
  92
  93 GML: setsharpness ( sharp -- ) c-bool> set-sharpness ;
  94 GML: getsharpness ( -- sharp ) get-sharpness >c-bool ;
  95 GML: pushsharpness ( sharp -- ) c-bool> push-sharpness ;
  96 GML: popsharpness ( -- sharp ) pop-sharpness >c-bool ;
  97
  98 GML: connectedvertices ( e0 e1 -- connected )
  99     ! Stupid variable-arity word!
 100     connecting-edge [ [ over push-operand ] when* ] [ >c-bool ] bi ;
 101
 102 M: b-edge write-gml
 103     dup vertex>> position>> vertex-style [
 104         "«Edge " write
 105         [ vertex>> position>> write-gml "-" write ] [
 106             opposite-edge>> vertex>> position>>
 107             dup vertex-style [ write-gml ] with-style
 108         ] bi
 109         "»" write
 110     ] with-style ;