unmaintained/adsoda/tools/tools.factor

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