unmaintained/adsoda/tools/tools.factor

   1 ! Copyright (C) 2008 Jeff Bigot\r
   2 ! See http://factorcode.org/license.txt for BSD license.\r
   3 USING: \r
   4 kernel\r
   5 sequences\r
   6 math\r
   7 accessors\r
   8 adsoda\r
   9 math.vectors \r
  10 math.matrices\r
  11 bunny.model\r
  12 io.encodings.ascii\r
  13 io.files\r
  14 sequences.deep\r
  15 combinators\r
  16 adsoda.combinators\r
  17 fry\r
  18 io.files.temp\r
  19 grouping\r
  20 ;\r
  21 \r
  22 IN: adsoda.tools\r
  23 \r
  24 \r
  25 \r
  26 \r
  27 \r
  28 ! ---------------------------------\r
  29 : coord-min ( x array -- array )  swap suffix  ;\r
  30 : coord-max ( x array -- array )  swap neg suffix ;\r
  31 \r
  32 : 4cube ( array name -- solid )\r
  33 ! array : xmin xmax ymin ymax zmin zmax wmin wmax\r
  34     <solid> \r
  35     4 >>dimension\r
  36     swap >>name\r
  37     swap\r
  38     { \r
  39        [ { 1 0 0 0 } coord-min ] [ { -1 0 0 0 } coord-max ] \r
  40        [ { 0 1 0 0 } coord-min ] [ { 0 -1 0 0 } coord-max ]\r
  41        [ { 0 0 1 0 } coord-min ] [ { 0 0 -1 0 } coord-max ] \r
  42        [ { 0 0 0 1 } coord-min ] [ { 0 0 0 -1 } coord-max ]\r
  43     }\r
  44     [ curry call ] 2map \r
  45     [ cut-solid ] each \r
  46     ensure-adjacencies\r
  47     \r
  48 ; inline\r
  49 \r
  50 : 3cube ( array name -- solid )\r
  51 ! array : xmin xmax ymin ymax zmin zmax wmin wmax\r
  52     <solid> \r
  53     3 >>dimension\r
  54     swap >>name\r
  55     swap\r
  56     { \r
  57        [ { 1 0 0 } coord-min ] [ { -1 0 0 } coord-max ] \r
  58        [ { 0 1 0 } coord-min ] [ { 0 -1 0 } coord-max ]\r
  59        [ { 0 0 1 } coord-min ] [ { 0 0 -1 } coord-max ] \r
  60     }\r
  61     [ curry call ] 2map \r
  62     [ cut-solid ] each \r
  63     ensure-adjacencies\r
  64     \r
  65 ; inline\r
  66 \r
  67 \r
  68 : equation-system-for-normal ( points -- matrix )\r
  69     unclip [ v- 0 suffix ] curry map\r
  70     dup first [ drop 1 ] map     suffix\r
  71 ;\r
  72 \r
  73 : normal-vector ( points -- v ) \r
  74     equation-system-for-normal\r
  75     intersect-hyperplanes ;\r
  76 \r
  77 : points-to-hyperplane ( points -- hyperplane )\r
  78     [ normal-vector 0 suffix ] [ first ] bi\r
  79     translate ;\r
  80 \r
  81 : refs-to-points ( points faces -- faces )\r
  82    [ swap [ nth 10 v*n { 100 100 100 } v+ ] curry map ] \r
  83    with map\r
  84 ;\r
  85 ! V{ { 0.1 0.2 } { 1.1 1.3 } } V{ { 1 0 } { 0 1 } }\r
  86 ! V{ { { 1.1 1.3 } { 0.1 0.2 } } { { 0.1 0.2 } { 1.1 1.3 } } }\r
  87 \r
  88 : ply-model-path ( -- path )\r
  89 \r
  90 ! "bun_zipper.ply" \r
  91 "screw2.ply"\r
  92 temp-file \r
  93 ;\r
  94 \r
  95 : read-bunny-model ( -- v )\r
  96 ply-model-path ascii [  parse-model ] with-file-reader\r
  97 \r
  98 refs-to-points\r
  99 ;\r
 100 \r
 101 : 3points-to-normal ( seq -- v )\r
 102     unclip [ v- ] curry map first2 cross normalize\r
 103 ;\r
 104 : 2-faces-to-prism ( seq seq -- seq )\r
 105   2dup\r
 106     [ do-cycle 2 clump ] bi@ concat-nth  \r
 107     !  3 faces rectangulaires\r
 108     swap prefix\r
 109     swap prefix\r
 110 ;    \r
 111 \r
 112 : Xpoints-to-prisme ( seq height -- cube )\r
 113     ! from 3 points gives a list of faces representing \r
 114     ! a cube of height "height"\r
 115     ! and of based on the three points\r
 116     ! a face is a group of 3 or mode points.   \r
 117     [ dup dup  3points-to-normal ] dip \r
 118     v*n [ v+ ] curry map ! 2 eme face triangulaire \r
 119     2-faces-to-prism  \r
 120 \r
 121 ! [ dup number? [ 1 + ] when ] deep-map\r
 122 ! dup keep \r
 123 ;\r
 124 \r
 125 \r
 126 : Xpoints-to-plane4D ( seq x y -- 4Dplane )\r
 127     ! from 3 points gives a list of faces representing \r
 128     ! a cube in 4th dim\r
 129     ! from x to y (height = y-x)\r
 130     ! and of based on the X points\r
 131     ! a face is a group of 3 or mode points.   \r
 132     '[ [ [ _ suffix ] map ] [ [ _ suffix ] map ] bi ] call\r
 133     2-faces-to-prism\r
 134 ;\r
 135 \r
 136 : 3pointsfaces-to-3Dsolidfaces ( seq -- seq )\r
 137     [ 1 Xpoints-to-prisme [ 100 \r
 138         110 Xpoints-to-plane4D ] map concat ] map \r
 139 \r
 140 ;\r
 141 \r
 142 : test-figure ( -- solid )\r
 143     <solid> \r
 144     2 >>dimension\r
 145     { 1 -1 -5 } cut-solid \r
 146     { -1 -1 -21 } cut-solid \r
 147     { -1 0 -12 } cut-solid \r
 148     { 1 2 16 } cut-solid\r
 149 ;\r
 150 \r