+++ /dev/null
-! Copyright (C) 2008 Jeff Bigot\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: help.markup help.syntax ;\r
-IN: adsoda\r
-\r
-! --------------------------------------------------------------\r
-! faces\r
-! --------------------------------------------------------------\r
-ARTICLE: "face-page" "Face in ADSODA"\r
-"explanation of faces"\r
-$nl\r
-"link to functions" $nl\r
-"what is an halfspace" $nl\r
-"halfspace touching-corners adjacent-faces" $nl\r
-"touching-corners list of pointers to the corners which touch this face" $nl\r
-"adjacent-faces list of pointers to the faces which touch this face"\r
-{ $subsections\r
- face\r
- <face>\r
-}\r
-"test relative position"\r
-{ $subsections\r
- point-inside-or-on-face?\r
- point-inside-face?\r
-}\r
-"handling face"\r
-{ $subsections\r
- flip-face\r
- face-translate\r
- face-transform\r
-}\r
-\r
-;\r
-\r
-HELP: face\r
-{ $class-description "a face is defined by"\r
-{ $list "halfspace equation" }\r
-{ $list "list of touching corners" }\r
-{ $list "list of adjacent faces" }\r
-$nl\r
-"Touching corners and adjacent faces are defined by algorithm thanks to other faces of the solid"\r
-}\r
-\r
-\r
-;\r
-HELP: <face> \r
-{ $values { "v" "an halfspace equation" } { "tuple" "a face" } } ;\r
-HELP: flip-face \r
-{ $values { "face" "a face" } { "face" "flipped face" } }\r
-{ $description "change the orientation of a face" }\r
-;\r
-\r
-HELP: face-translate \r
-{ $values { "face" "a face" } { "v" "a vector" } }\r
-{ $description \r
-"translate a face following a vector"\r
-$nl\r
-"a translation of an halfspace doesn't change the normal vector. this word just compute the new constant term" }\r
-\r
- \r
- ;\r
-HELP: face-transform \r
-{ $values { "face" "a face" } { "m" "a transformation matrix" } }\r
-{ $description "compute the transformation of a face using a transformation matrix" }\r
- \r
- ;\r
-! --------------------------------\r
-! solid\r
-! --------------------------------------------------------------\r
-ARTICLE: "solid-page" "Solid in ADSODA"\r
-"explanation of solids"\r
-$nl\r
-"link to functions"\r
-{ $subsections\r
- solid\r
- <solid>\r
-}\r
-"test relative position"\r
-{ $subsections\r
- point-inside-solid?\r
- point-inside-or-on-solid?\r
-}\r
-"playing with faces and solids"\r
-{ $subsections\r
- add-face\r
- cut-solid\r
- slice-solid\r
-}\r
-"solid handling"\r
-{ $subsections\r
- solid-project\r
- solid-translate\r
- solid-transform\r
- subtract\r
- get-silhouette \r
- solid=\r
-}\r
-;\r
-\r
-HELP: solid \r
-{ $class-description "dimension" $nl "silhouettes" $nl "faces" $nl "corners" $nl "adjacencies-valid" $nl "color" $nl "name" \r
-}\r
-;\r
-\r
-HELP: add-face \r
-{ $values { "solid" "a solid" } { "face" "a face" } }\r
-{ $description "reshape a solid with a face. The face truncate the solid." } ;\r
-\r
-HELP: cut-solid\r
-{ $values { "solid" "a solid" } { "halfspace" "an halfspace" } }\r
-{ $description "like add-face but just with halfspace equation" } ;\r
-\r
-HELP: slice-solid\r
-{ $values { "solid" "a solid" } { "face" "a face" } { "solid1" "the outer part of the former solid" } { "solid2" "the inner part of the former solid" } }\r
-{ $description "cut a solid into two parts. The face acts like a knife"\r
-} ;\r
-\r
-\r
-HELP: solid-project\r
-{ $values { "lights" "lights" } { "ambient" "ambient" } { "solid" "solid" } { "solids" "projection of solid" } }\r
-{ $description "Project the solid using pv vector" \r
-$nl\r
-"TODO: explain how to use lights"\r
-} ;\r
-\r
-HELP: solid-translate \r
-{ $values { "solid" "a solid" } { "v" "translating vector" } }\r
-{ $description "Translate a solid using a vector" \r
-$nl\r
-"v and solid must have the same dimension "\r
-} ;\r
-\r
-HELP: solid-transform \r
-{ $values { "solid" "a solid" } { "m" "transformation matrix" } }\r
-{ $description "Transform a solid using a matrix"\r
-$nl\r
-"v and solid must have the same dimension "\r
-} ;\r
-\r
-HELP: subtract \r
-{ $values { "solid1" "initial shape" } { "solid2" "shape to remove" } { "solids" "resulting shape" } }\r
-{ $description "Substract solid2 from solid1" } ;\r
-\r
-\r
-! --------------------------------------------------------------\r
-! space \r
-! --------------------------------------------------------------\r
-ARTICLE: "space-page" "Space in ADSODA"\r
-"A space is a collection of solids and lights."\r
-$nl\r
-"link to functions"\r
-$nl\r
-"Defining words"\r
-{ $subsections\r
- space\r
- <space>\r
- suffix-solids \r
- suffix-lights\r
- clear-space-solids \r
- describe-space\r
-}\r
-\r
-\r
-"Handling space"\r
-{ $subsections\r
- space-ensure-solids\r
- eliminate-empty-solids\r
- space-transform\r
- space-translate\r
- remove-hidden-solids\r
- space-project\r
-}\r
-\r
-\r
-;\r
-\r
-HELP: space \r
-{ $class-description \r
-"dimension" $nl " solids" $nl " ambient-color" $nl "lights" \r
-}\r
-;\r
-\r
-HELP: suffix-solids \r
-"( space solid -- space )"\r
-{ $values { "space" "a space" } { "solid" "a solid to add" } }\r
-{ $description "Add solid to space definition" } ;\r
-\r
-HELP: suffix-lights \r
-"( space light -- space ) "\r
-{ $values { "space" "a space" } { "light" "a light to add" } }\r
-{ $description "Add a light to space definition" } ;\r
-\r
-HELP: clear-space-solids \r
-"( space -- space )" \r
-{ $values { "space" "a space" } }\r
-{ $description "remove all solids in space" } ;\r
-\r
-HELP: space-ensure-solids \r
-{ $values { "space" "a space" } }\r
-{ $description "rebuild corners of all solids in space" } ;\r
-\r
-\r
-\r
-HELP: space-transform \r
-" ( space m -- space )" \r
-{ $values { "space" "a space" } { "m" "a matrix" } }\r
-{ $description "Transform a space using a matrix" } ;\r
-\r
-HELP: space-translate \r
-{ $values { "space" "a space" } { "v" "a vector" } }\r
-{ $description "Translate a space following a vector" } ;\r
-\r
-HELP: describe-space " ( space -- )"\r
-{ $values { "space" "a space" } }\r
-{ $description "return a description of space" } ;\r
-\r
-HELP: space-project \r
-{ $values { "space" "a space" } { "i" "an integer" } }\r
-{ $description "Project a space along ith coordinate" } ;\r
-\r
-! --------------------------------------------------------------\r
-! 3D rendering\r
-! --------------------------------------------------------------\r
-ARTICLE: "3D-rendering-page" "The 3D rendering in ADSODA"\r
-"explanation of 3D rendering"\r
-$nl\r
-"link to functions"\r
-{ $subsections\r
- face->GL\r
- solid->GL\r
- space->GL\r
-}\r
-\r
-;\r
-\r
-HELP: face->GL \r
-{ $values { "face" "a face" } { "color" "3 3 values array" } }\r
-{ $description "display a face" } ;\r
-\r
-HELP: solid->GL \r
-{ $values { "solid" "a solid" } }\r
-{ $description "display a solid" } ;\r
-\r
-HELP: space->GL \r
-{ $values { "space" "a space" } }\r
-{ $description "display a space" } ;\r
-\r
-! --------------------------------------------------------------\r
-! light\r
-! --------------------------------------------------------------\r
-\r
-ARTICLE: "light-page" "Light in ADSODA"\r
-"explanation of light"\r
-$nl\r
-"link to functions"\r
-;\r
-\r
-ARTICLE: { "adsoda" "light" } "ADSODA : lights"\r
-{ $code """\r
-! HELP: light position color\r
-! <light> ( -- tuple ) light new ;\r
-! light est un vecteur avec 3 variables pour les couleurs\n\r
- void Light::Apply(Vector& normal, double &cRed, double &cGreen, double &cBlue)\n\r
- { \n\r
- // Dot the light direction with the normalized normal of Face.\r
- register double intensity = -(normal * (*this));\r
- // Face is a backface, from light's perspective\r
- if (intensity < 0)\r
- return;\r
- \r
- // Add the intensity componentwise\r
- cRed += red * intensity;\r
- cGreen += green * intensity;\r
- cBlue += blue * intensity;\r
- // Clip to unit range\r
- if (cRed > 1.0) cRed = 1.0;\r
- if (cGreen > 1.0) cGreen = 1.0;\r
- if (cBlue > 1.0) cBlue = 1.0;\r
-""" }\r
-;\r
-\r
-\r
-\r
-ARTICLE: { "adsoda" "halfspace" } "ADSODA : halfspace"\r
-" defined by the concatenation of the normal vector and a constant" \r
- ;\r
-\r
-\r
-\r
-ARTICLE: "adsoda-main-page" "ADSODA : Arbitrary-Dimensional Solid Object Display Algorithm"\r
-"multidimensional handler :" \r
-$nl\r
-"design a solid using face delimitations. Only works on convex shapes"\r
-$nl\r
-{ $emphasis "written in C++ by Greg Ferrar" }\r
-$nl\r
-"full explanation on adsoda page at " { $url "http://www.flowerfire.com/ADSODA/" }\r
-$nl\r
-"Useful words are describe on the following pages: "\r
-{ $subsections\r
- "face-page"\r
- "solid-page"\r
- "space-page"\r
- "light-page"\r
- "3D-rendering-page"\r
-} ;\r
-\r
-ABOUT: "adsoda-main-page"\r
+++ /dev/null
-USING: adsoda\r
-kernel\r
-math\r
-accessors\r
-sequences\r
- adsoda.solution2\r
- fry\r
- tools.test \r
- arrays ;\r
-\r
-IN: adsoda.tests\r
-\r
-\r
-\r
-: s1 ( -- solid )\r
- <solid> \r
- 2 >>dimension\r
- "s1" >>name\r
- { 1 1 1 } >>color\r
- { 1 -1 -5 } cut-solid \r
- { -1 -1 -21 } cut-solid \r
- { -1 0 -12 } cut-solid \r
- { 1 2 16 } cut-solid\r
-;\r
-: solid1 ( -- solid )\r
- <solid> \r
- 2 >>dimension\r
- "solid1" >>name\r
- { 1 -1 -5 } cut-solid \r
- { -1 -1 -21 } cut-solid \r
- { -1 0 -12 } cut-solid \r
- { 1 2 16 } cut-solid\r
- ensure-adjacencies\r
- \r
-;\r
-: solid2 ( -- solid )\r
- <solid> \r
- 2 >>dimension\r
- "solid2" >>name\r
- { -1 1 -10 } cut-solid \r
- { -1 -1 -28 } cut-solid \r
- { 1 0 13 } cut-solid \r
- ! { 1 2 16 } cut-solid\r
- ensure-adjacencies\r
- \r
-;\r
-\r
-: solid3 ( -- solid )\r
- <solid> \r
- 2 >>dimension\r
- "solid3" >>name\r
- { 1 1 1 } >>color\r
- { 1 0 16 } cut-solid \r
- { -1 0 -36 } cut-solid \r
- { 0 1 1 } cut-solid \r
- { 0 -1 -17 } cut-solid \r
- ! { 1 2 16 } cut-solid\r
- ensure-adjacencies\r
- \r
-\r
-;\r
-\r
-: solid4 ( -- solid )\r
- <solid> \r
- 2 >>dimension\r
- "solid4" >>name\r
- { 1 1 1 } >>color\r
- { 1 0 21 } cut-solid \r
- { -1 0 -36 } cut-solid \r
- { 0 1 1 } cut-solid \r
- { 0 -1 -17 } cut-solid \r
- ensure-adjacencies\r
- \r
-;\r
-\r
-: solid5 ( -- solid )\r
- <solid> \r
- 2 >>dimension\r
- "solid5" >>name\r
- { 1 1 1 } >>color\r
- { 1 0 6 } cut-solid \r
- { -1 0 -17 } cut-solid \r
- { 0 1 17 } cut-solid \r
- { 0 -1 -19 } cut-solid \r
- ensure-adjacencies\r
- \r
-;\r
-\r
-: solid7 ( -- solid )\r
- <solid> \r
- 2 >>dimension\r
- "solid7" >>name\r
- { 1 1 1 } >>color\r
- { 1 0 38 } cut-solid \r
- { 1 -5 -66 } cut-solid \r
- { -2 1 -75 } cut-solid\r
- ensure-adjacencies\r
- \r
-;\r
-\r
-: solid6s ( -- seq )\r
- solid3 clone solid2 clone subtract\r
-;\r
-\r
-: space1 ( -- space )\r
- <space>\r
- 2 >>dimension\r
- ! solid3 suffix-solids\r
- solid1 suffix-solids\r
- solid2 suffix-solids\r
- ! solid6s [ suffix-solids ] each \r
- solid4 suffix-solids\r
- ! solid5 suffix-solids\r
- solid7 suffix-solids\r
- { 1 1 1 } >>ambient-color\r
- <light>\r
- { -100 -100 } >>position\r
- { 0.2 0.7 0.1 } >>color\r
- suffix-lights\r
-;\r
-\r
-: space2 ( -- space )\r
- <space>\r
- 4 >>dimension\r
- ! 4cube suffix-solids\r
- { 1 1 1 } >>ambient-color\r
- <light>\r
- { -100 -100 } >>position\r
- { 0.2 0.7 0.1 } >>color\r
- suffix-lights\r
-\r
- ;\r
-\r
-\r
-\r
-! {\r
-! { 1 0 0 0 }\r
-! { 0 1 0 0 }\r
-! { 0 0 0.984807753012208 -0.1736481776669303 }\r
-! { 0 0 0.1736481776669303 0.984807753012208 }\r
-! }\r
-\r
-! ------------------------------------------------------------\r
-! constant+\r
-[ { 1 2 5 } ] [ { 1 2 3 } 2 constant+ ] unit-test\r
-\r
-! ------------------------------------------------------------\r
-! translate\r
-[ { 1 -1 0 } ] [ { 1 -1 -5 } { 3 -2 } translate ] unit-test\r
-\r
-! ------------------------------------------------------------\r
-! transform\r
-[ { -1 -1 -5 21.0 } ] [ { -1 -1 -5 21 }\r
- { { 1 0 0 }\r
- { 0 1 0 }\r
- { 0 0 1 }\r
- } transform \r
-] unit-test\r
-\r
-! ------------------------------------------------------------\r
-! compare-nleft-to-identity-matrix\r
-[ t ] [ \r
- { \r
- { 1 0 0 1232 } \r
- { 0 1 0 0 321 } \r
- { 0 0 1 0 } } \r
- 3 compare-nleft-to-identity-matrix \r
-] unit-test\r
-\r
-[ f ] [ \r
- { { 1 0 0 } { 0 1 0 } { 0 0 0 } } \r
- 3 compare-nleft-to-identity-matrix \r
-] unit-test\r
-\r
-[ f ] [ \r
- { { 2 0 0 } { 0 1 0 } { 0 0 1 } } \r
- 3 compare-nleft-to-identity-matrix \r
-] unit-test\r
-! ------------------------------------------------------------\r
-[ t ] [ \r
- { { 1 0 0 }\r
- { 0 1 0 }\r
- { 0 0 1 } } 3 valid-solution? \r
-] unit-test\r
-\r
-[ f ] [ \r
- { { 1 0 0 1 }\r
- { 0 0 0 1 }\r
- { 0 0 1 0 } } 3 valid-solution? \r
-] unit-test\r
-\r
-[ f ] [ \r
- { { 1 0 0 1 }\r
- { 0 0 0 1 } } 3 valid-solution? \r
-] unit-test\r
-\r
-[ f ] [ \r
- { { 1 0 0 1 }\r
- { 0 0 0 1 }\r
- { 0 0 1 0 } } 2 valid-solution? \r
-] unit-test\r
-\r
-! ------------------------------------------------------------\r
-[ 3 ] [ { 1 2 3 } last ] unit-test \r
-\r
-[ { 1 2 5 } ] [ { 1 2 3 } dup [ 2 + ] change-last ] unit-test \r
-\r
-! ------------------------------------------------------------\r
-! position-point \r
-[ 0 ] [ \r
- { 1 -1 -5 } { 2 7 } position-point \r
-] unit-test\r
-\r
-! ------------------------------------------------------------\r
-\r
-! transform\r
-! TODO construire un exemple\r
-\r
-\r
-! ------------------------------------------------------------\r
-! slice-solid \r
-\r
-! ------------------------------------------------------------\r
-! solve-equation \r
-! deux cas de tests, avec solution et sans solution\r
-\r
-[ { 2 7 } ] \r
-[ { { 1 -1 -5 } { 1 2 16 } } intersect-hyperplanes ] \r
-unit-test\r
-\r
-[ f ] \r
-[ { { 1 -1 -5 } { 1 2 16 } { -1 -1 -21 } } intersect-hyperplanes ]\r
-unit-test\r
-\r
-[ f ] \r
-[ { { 1 0 -5 } { 1 0 16 } } intersect-hyperplanes ]\r
-unit-test\r
-\r
-! ------------------------------------------------------------\r
-! point-inside-halfspace\r
-[ t ] [ { 1 -1 -5 } { 0 0 } point-inside-halfspace? ] \r
-unit-test\r
-[ f ] [ { 1 -1 -5 } { 8 13 } point-inside-halfspace? ] \r
-unit-test\r
-[ t ] [ { 1 -1 -5 } { 8 13 } point-inside-or-on-halfspace? ] \r
-unit-test\r
-\r
-\r
-! ------------------------------\r
-! order solid\r
-\r
-[ 1 ] [ 0 >pv solid1 solid2 order-solid ] unit-test\r
-[ -1 ] [ 0 >pv solid2 solid1 order-solid ] unit-test\r
-[ f ] [ 1 >pv solid1 solid2 order-solid ] unit-test\r
-[ f ] [ 1 >pv solid2 solid1 order-solid ] unit-test\r
-\r
-\r
-! clip-solid\r
-[ { { 13 15 } { 15 13 } { 13 13 } } ]\r
- [ 0 >pv solid2 solid1 clip-solid first corners>> ] unit-test\r
-\r
-solid1 corners>> '[ _ ]\r
- [ 0 >pv solid1 solid1 clip-solid first corners>> ] unit-test\r
-\r
-solid1 corners>> '[ _ ]\r
- [ 0 >pv solid1 solid2 clip-solid first corners>> ] unit-test\r
-\r
-solid1 corners>> '[ _ ]\r
- [ 1 >pv solid1 solid2 clip-solid first corners>> ] unit-test\r
-solid2 corners>> '[ _ ]\r
- [ 1 >pv solid2 solid1 clip-solid first corners>> ] unit-test\r
-\r
-!\r
-[\r
- {\r
- { { 13 15 } { 15 13 } { 13 13 } }\r
- { { 16 17 } { 16 13 } { 36 17 } { 36 13 } }\r
- { { 16 1 } { 16 2 } { 36 1 } { 36 2 } }\r
- }\r
-] [ 0 >pv solid2 solid3 2array \r
- solid1 (solids-silhouette-subtract) \r
- [ corners>> ] map\r
- ] unit-test\r
-\r
-\r
-[\r
-{\r
- { { 8 13 } { 2 7 } { 12 9 } { 12 2 } }\r
- { { 13 15 } { 15 13 } { 13 13 } }\r
- { { 16 17 } { 16 15 } { 36 17 } { 36 15 } }\r
- { { 16 1 } { 16 2 } { 36 1 } { 36 2 } }\r
-}\r
-] [ \r
- 0 >pv <space> solid1 suffix-solids \r
- solid2 suffix-solids \r
- solid3 suffix-solids\r
- remove-hidden-solids\r
- solids>> [ corners>> ] map\r
-] unit-test\r
-\r
-! { }\r
-! { }\r
-! <light> { 0.2 0.3 0.4 } >>color { 1 -1 1 } >>direction suffix\r
-! <light> { 0.4 0.3 0.1 } >>color { -1 -1 -1 } >>direction suffix\r
-! suffix \r
-! { 0.1 0.1 0.1 } suffix ! ambient color\r
-! { 0.23 0.32 0.17 } suffix ! solid color\r
-! solid3 faces>> first \r
-\r
-! enlight-projection\r
+++ /dev/null
-! Copyright (C) 2008 Jeff Bigot\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: accessors\r
-arrays \r
-assocs\r
-combinators\r
-kernel \r
-fry\r
-math \r
-math.constants\r
-math.functions\r
-math.libm\r
-math.order\r
-math.vectors \r
-math.matrices \r
-math.parser\r
-namespaces\r
-prettyprint\r
-sequences\r
-sequences.deep\r
-sets\r
-slots\r
-sorting\r
-tools.time\r
-vars\r
-continuations\r
-words\r
-opengl\r
-opengl.gl\r
-colors\r
-adsoda.solution2\r
-adsoda.combinators\r
-opengl.demo-support\r
-values\r
-tools.walker\r
-;\r
-\r
-IN: adsoda\r
-\r
-DEFER: combinations\r
-VAR: pv\r
-\r
-\r
-! -------------------------------------------------------------\r
-! global values\r
-VALUE: remove-hidden-solids?\r
-VALUE: VERY-SMALL-NUM\r
-VALUE: ZERO-VALUE\r
-VALUE: MAX-FACE-PER-CORNER\r
-\r
-t to: remove-hidden-solids?\r
-0.0000001 to: VERY-SMALL-NUM\r
-0.0000001 to: ZERO-VALUE\r
-4 to: MAX-FACE-PER-CORNER\r
-! -------------------------------------------------------------\r
-! sequence complement\r
-\r
-: with-pv ( i quot -- ) [ swap >pv call ] with-scope ; inline\r
-\r
-: dimension ( array -- x ) length 1 - ; inline \r
-: change-last ( seq quot -- ) \r
- [ [ dimension ] keep ] dip change-nth ; inline\r
-\r
-! -------------------------------------------------------------\r
-! light\r
-! -------------------------------------------------------------\r
-\r
-TUPLE: light name { direction array } color ;\r
-: <light> ( -- tuple ) light new ;\r
-\r
-! -------------------------------------------------------------\r
-! halfspace manipulation\r
-! -------------------------------------------------------------\r
-\r
-: constant+ ( v x -- w ) '[ [ _ + ] change-last ] keep ;\r
-: translate ( u v -- w ) dupd v* sum constant+ ; \r
-\r
-: transform ( u matrix -- w )\r
- [ swap m.v ] 2keep ! compute new normal vector \r
- [\r
- [ [ abs ZERO-VALUE > ] find ] keep \r
- ! find a point on the frontier\r
- ! be sure it's not null vector\r
- last ! get constant\r
- swap /f neg swap ! intercept value\r
- ] dip \r
- flip \r
- nth\r
- [ * ] with map ! apply intercep value\r
- over v*\r
- sum neg\r
- suffix ! add value as constant at the end of equation\r
-;\r
-\r
-: position-point ( halfspace v -- x ) \r
- -1 suffix v* sum ; inline\r
-: point-inside-halfspace? ( halfspace v -- ? ) \r
- position-point VERY-SMALL-NUM > ; \r
-: point-inside-or-on-halfspace? ( halfspace v -- ? ) \r
- position-point VERY-SMALL-NUM neg > ;\r
-: project-vector ( seq -- seq ) \r
- pv> [ head ] [ 1 + tail ] 2bi append ; \r
-: get-intersection ( matrice -- seq ) \r
- [ 1 tail* ] map flip first ;\r
-\r
-: islenght=? ( seq n -- seq n ? ) 2dup [ length ] [ = ] bi* ;\r
-\r
-: compare-nleft-to-identity-matrix ( seq n -- ? ) \r
- [ [ head ] curry map ] keep identity-matrix m- \r
- flatten\r
- [ abs ZERO-VALUE < ] all?\r
-;\r
-\r
-: valid-solution? ( matrice n -- ? )\r
- islenght=?\r
- [ compare-nleft-to-identity-matrix ] \r
- [ 2drop f ] if ; inline\r
-\r
-: intersect-hyperplanes ( matrice -- seq )\r
- [ solution dup ] [ first dimension ] bi\r
- valid-solution? [ get-intersection ] [ drop f ] if ;\r
-\r
-! -------------------------------------------------------------\r
-! faces\r
-! -------------------------------------------------------------\r
-\r
-TUPLE: face { halfspace array } \r
- touching-corners adjacent-faces ;\r
-: <face> ( v -- tuple ) face new swap >>halfspace ;\r
-: flip-face ( face -- face ) [ vneg ] change-halfspace ;\r
-: erase-face-touching-corners ( face -- face ) \r
- f >>touching-corners ;\r
-: erase-face-adjacent-faces ( face -- face ) \r
- f >>adjacent-faces ;\r
-: faces-intersection ( faces -- v ) \r
- [ halfspace>> ] map intersect-hyperplanes ;\r
-: face-translate ( face v -- face ) \r
- [ translate ] curry change-halfspace ; inline\r
-: face-transform ( face m -- face )\r
- [ transform ] curry change-halfspace ; inline\r
-: face-orientation ( face -- x ) pv> swap halfspace>> nth sgn ;\r
-: backface? ( face -- face ? ) dup face-orientation 0 <= ;\r
-: pv-factor ( face -- f face ) \r
- halfspace>> [ pv> swap nth [ * ] curry ] keep ; inline\r
-: suffix-touching-corner ( face corner -- face ) \r
- [ suffix ] curry change-touching-corners ; inline\r
-: real-face? ( face -- ? )\r
- [ touching-corners>> length ] \r
- [ halfspace>> dimension ] bi >= ;\r
-\r
-: (add-to-adjacent-faces) ( face face -- face )\r
- over adjacent-faces>> 2dup member?\r
- [ 2drop ] [ swap suffix >>adjacent-faces ] if ;\r
-\r
-: add-to-adjacent-faces ( face face -- face )\r
- 2dup = [ drop ] [ (add-to-adjacent-faces) ] if ;\r
-\r
-: update-adjacent-faces ( faces corner -- )\r
- '[ [ _ suffix-touching-corner drop ] each ] keep \r
- 2 among [ \r
- [ first ] keep second \r
- [ add-to-adjacent-faces drop ] 2keep \r
- swap add-to-adjacent-faces drop \r
- ] each ; inline\r
-\r
-: face-project-dim ( face -- x ) halfspace>> length 2 - ;\r
-\r
-: apply-light ( color light normal -- u )\r
- over direction>> v. \r
- neg dup 0 > \r
- [ \r
- [ color>> swap ] dip \r
- [ * ] curry map v+ \r
- [ 1 min ] map \r
- ] \r
- [ 2drop ] \r
- if\r
-;\r
-\r
-: enlight-projection ( array face -- color )\r
- ! array = lights + ambient color\r
- [ [ third ] [ second ] [ first ] tri ]\r
- [ halfspace>> project-vector normalize ] bi*\r
- [ apply-light ] curry each\r
- v*\r
-;\r
-\r
-: (intersection-into-face) ( face-init face-adja quot -- face )\r
- [\r
- [ [ pv-factor ] bi@ \r
- roll \r
- [ map ] 2bi@\r
- v-\r
- ] 2keep\r
- [ touching-corners>> ] bi@\r
- [ swap [ = ] curry find nip f = ] curry find nip\r
- ] dip over\r
- [\r
- call\r
- dupd\r
- point-inside-halfspace? [ vneg ] unless \r
- <face> \r
- ] [ 3drop f ] if \r
- ; inline\r
-\r
-: intersection-into-face ( face-init face-adja -- face )\r
- [ [ project-vector ] bi@ ] (intersection-into-face) ;\r
-\r
-: intersection-into-silhouette-face ( face-init face-adja -- face )\r
- [ ] (intersection-into-face) ;\r
-\r
-: intersections-into-faces ( face -- faces )\r
- clone dup \r
- adjacent-faces>> [ intersection-into-face ] with map \r
- [ ] filter ;\r
-\r
-: (face-silhouette) ( face -- faces )\r
- clone dup adjacent-faces>>\r
- [ backface?\r
- [ intersection-into-silhouette-face ] [ 2drop f ] if \r
- ] with map \r
- [ ] filter\r
-; inline\r
-\r
-: face-silhouette ( face -- faces ) \r
- backface? [ drop f ] [ (face-silhouette) ] if ;\r
-\r
-! --------------------------------\r
-! solid\r
-! -------------------------------------------------------------\r
-TUPLE: solid dimension silhouettes \r
- faces corners adjacencies-valid color name ;\r
-\r
-: <solid> ( -- tuple ) solid new ;\r
-\r
-: suffix-silhouettes ( solid silhouette -- solid ) \r
- [ suffix ] curry change-silhouettes ;\r
-\r
-: suffix-face ( solid face -- solid ) \r
- [ suffix ] curry change-faces ;\r
-: suffix-corner ( solid corner -- solid ) \r
- [ suffix ] curry change-corners ; \r
-: erase-solid-corners ( solid -- solid ) f >>corners ;\r
-\r
-: erase-silhouettes ( solid -- solid ) \r
- dup dimension>> f <array> >>silhouettes ;\r
-: filter-real-faces ( solid -- solid ) \r
- [ [ real-face? ] filter ] change-faces ;\r
-: initiate-solid-from-face ( face -- solid ) \r
- face-project-dim <solid> swap >>dimension ;\r
-\r
-: erase-old-adjacencies ( solid -- solid )\r
- erase-solid-corners\r
- [ dup [ erase-face-touching-corners \r
- erase-face-adjacent-faces drop ] each ]\r
- change-faces ;\r
-\r
-: point-inside-or-on-face? ( face v -- ? ) \r
- [ halfspace>> ] dip point-inside-or-on-halfspace? ;\r
-\r
-: point-inside-face? ( face v -- ? ) \r
- [ halfspace>> ] dip point-inside-halfspace? ;\r
-\r
-: point-inside-solid? ( solid point -- ? )\r
- [ faces>> ] dip [ point-inside-face? ] curry all? ; inline\r
-\r
-: point-inside-or-on-solid? ( solid point -- ? )\r
- [ faces>> ] dip \r
- [ point-inside-or-on-face? ] curry all? ; inline\r
-\r
-: unvalid-adjacencies ( solid -- solid ) \r
- erase-old-adjacencies f >>adjacencies-valid \r
- erase-silhouettes ;\r
-\r
-: add-face ( solid face -- solid ) \r
- suffix-face unvalid-adjacencies ; \r
-\r
-: cut-solid ( solid halfspace -- solid ) <face> add-face ; \r
-\r
-: slice-solid ( solid face -- solid1 solid2 )\r
- [ [ clone ] bi@ flip-face add-face \r
- [ "/outer/" append ] change-name ] 2keep\r
- add-face [ "/inner/" append ] change-name ;\r
-\r
-! -------------\r
-\r
-\r
-: add-silhouette ( solid -- solid )\r
- dup \r
- ! find-adjacencies \r
- faces>> { } \r
- [ face-silhouette append ] reduce\r
- [ ] filter \r
- <solid> \r
- swap >>faces\r
- over dimension>> >>dimension \r
- over name>> " silhouette " append \r
- pv> number>string append \r
- >>name\r
- ! ensure-adjacencies\r
- suffix-silhouettes ; inline\r
-\r
-: find-silhouettes ( solid -- solid )\r
- { } >>silhouettes \r
- dup dimension>> [ [ add-silhouette ] with-pv ] each ;\r
-\r
-: ensure-silhouettes ( solid -- solid )\r
- dup silhouettes>> [ f = ] all?\r
- [ find-silhouettes ] when ; \r
-\r
-! ------------\r
-\r
-: corner-added? ( solid corner -- ? ) \r
- ! add corner to solid if it is inside solid\r
- [ ] \r
- [ point-inside-or-on-solid? ] \r
- [ swap corners>> member? not ] \r
- 2tri and\r
- [ suffix-corner drop t ] [ 2drop f ] if ;\r
-\r
-: process-corner ( solid faces corner -- )\r
- swapd \r
- [ corner-added? ] keep swap ! test if corner is inside solid\r
- [ update-adjacent-faces ] \r
- [ 2drop ]\r
- if ;\r
-\r
-: compute-intersection ( solid faces -- )\r
- dup faces-intersection\r
- dup f = [ 3drop ] [ process-corner ] if ;\r
-\r
-: test-faces-combinaisons ( solid n -- )\r
- [ dup faces>> ] dip among \r
- [ compute-intersection ] with each ;\r
-\r
-: compute-adjacencies ( solid -- solid )\r
- dup dimension>> [ >= ] curry \r
- [ keep swap ] curry MAX-FACE-PER-CORNER swap\r
- [ [ test-faces-combinaisons ] 2keep 1 - ] while drop ;\r
-\r
-: find-adjacencies ( solid -- solid ) \r
- erase-old-adjacencies \r
- compute-adjacencies\r
- filter-real-faces \r
- t >>adjacencies-valid ;\r
-\r
-: ensure-adjacencies ( solid -- solid ) \r
- dup adjacencies-valid>> \r
- [ find-adjacencies ] unless \r
- ensure-silhouettes\r
- ;\r
-\r
-: (non-empty-solid?) ( solid -- ? ) \r
- [ dimension>> ] [ corners>> length ] bi < ;\r
-: non-empty-solid? ( solid -- ? ) \r
- ensure-adjacencies (non-empty-solid?) ;\r
-\r
-: compare-corners-roughly ( corner corner -- ? )\r
- 2drop t ;\r
-! : remove-inner-faces ( -- ) ;\r
-: face-project ( array face -- seq )\r
- backface? \r
- [ 2drop f ]\r
- [ [ enlight-projection ] \r
- [ initiate-solid-from-face ]\r
- [ intersections-into-faces ] tri\r
- >>faces\r
- swap >>color \r
- ] if ;\r
-\r
-: solid-project ( lights ambient solid -- solids )\r
- ensure-adjacencies\r
- [ color>> ] [ faces>> ] bi [ 3array ] dip\r
- [ face-project ] with map \r
- [ ] filter \r
- [ ensure-adjacencies ] map\r
-;\r
-\r
-: (solid-move) ( solid v move -- solid ) \r
- curry [ map ] curry \r
- [ dup faces>> ] dip call drop \r
- unvalid-adjacencies ; inline\r
-\r
-: solid-translate ( solid v -- solid ) \r
- [ face-translate ] (solid-move) ; \r
-: solid-transform ( solid m -- solid ) \r
- [ face-transform ] (solid-move) ; \r
-\r
-: find-corner-in-silhouette ( s1 s2 -- elt bool )\r
- pv> swap silhouettes>> nth \r
- swap corners>>\r
- [ point-inside-solid? ] with find swap ;\r
-\r
-: valid-face-for-order ( solid point -- face )\r
- [ point-inside-face? not ] \r
- [ drop face-orientation 0 = not ] 2bi and ;\r
-\r
-: check-orientation ( s1 s2 pt -- int )\r
- [ nip faces>> ] dip\r
- [ valid-face-for-order ] curry find swap\r
- [ face-orientation ] [ drop f ] if ;\r
-\r
-: (order-solid) ( s1 s2 -- int )\r
- 2dup find-corner-in-silhouette\r
- [ check-orientation ] [ 3drop f ] if ;\r
-\r
-: order-solid ( solid solid -- i ) \r
- 2dup (order-solid)\r
- [ 2nip ]\r
- [ swap (order-solid)\r
- [ neg ] [ f ] if*\r
- ] if* ;\r
-\r
-: subtract ( solid1 solid2 -- solids )\r
- faces>> swap clone ensure-adjacencies ensure-silhouettes \r
- [ swap slice-solid drop ] curry map\r
- [ non-empty-solid? ] filter\r
- [ ensure-adjacencies ] map\r
-; inline\r
-\r
-! -------------------------------------------------------------\r
-! space \r
-! -------------------------------------------------------------\r
-TUPLE: space name dimension solids ambient-color lights ;\r
-: <space> ( -- space ) space new ;\r
-: suffix-solids ( space solid -- space ) \r
- [ suffix ] curry change-solids ; inline\r
-: suffix-lights ( space light -- space ) \r
- [ suffix ] curry change-lights ; inline\r
-: clear-space-solids ( space -- space ) f >>solids ;\r
-\r
-: space-ensure-solids ( space -- space ) \r
- [ [ ensure-adjacencies ] map ] change-solids ;\r
-: eliminate-empty-solids ( space -- space ) \r
- [ [ non-empty-solid? ] filter ] change-solids ;\r
-\r
-: projected-space ( space solids -- space ) \r
- swap dimension>> 1 - <space> \r
- swap >>dimension swap >>solids ;\r
-\r
-: get-silhouette ( solid -- silhouette ) \r
- silhouettes>> pv> swap nth ;\r
-: solid= ( solid solid -- ? ) [ corners>> ] bi@ = ;\r
-\r
-: space-apply ( space m quot -- space ) \r
- curry [ map ] curry [ dup solids>> ] dip\r
- [ call ] [ 2drop ] recover drop ; inline\r
-: space-transform ( space m -- space ) \r
- [ solid-transform ] space-apply ;\r
-: space-translate ( space v -- space ) \r
- [ solid-translate ] space-apply ; \r
-\r
-: describe-space ( space -- ) \r
- solids>> \r
- [ [ corners>> [ pprint ] each ] [ name>> . ] bi ] each ;\r
-\r
-: clip-solid ( solid solid -- solids )\r
- [ ]\r
- [ solid= not ]\r
- [ order-solid -1 = ] 2tri \r
- and\r
- [ get-silhouette subtract ] \r
- [ drop 1array ] \r
- if \r
- \r
- ;\r
-\r
-: (solids-silhouette-subtract) ( solids solid -- solids ) \r
- [ clip-solid append ] curry { } -rot each ; inline\r
-\r
-: solids-silhouette-subtract ( solids i solid -- solids )\r
-! solids is an array of 1 solid arrays\r
- [ (solids-silhouette-subtract) ] curry map-but \r
-; inline \r
-\r
-: remove-hidden-solids ( space -- space ) \r
-! We must include each solid in a sequence because \r
-! during substration \r
-! a solid can be divided in more than on solid\r
- [ \r
- [ [ 1array ] map ] \r
- [ length ] \r
- [ ] \r
- tri \r
- [ solids-silhouette-subtract ] 2each\r
- { } [ append ] reduce \r
- ] change-solids\r
- eliminate-empty-solids ! TODO include into change-solids\r
-;\r
-\r
-: space-project ( space i -- space )\r
- [\r
- [ clone \r
- remove-hidden-solids? [ remove-hidden-solids ] when\r
- dup \r
- [ solids>> ] \r
- [ lights>> ] \r
- [ ambient-color>> ] tri \r
- [ rot solid-project ] 2curry \r
- map \r
- [ append ] { } -rot each \r
- ! TODO project lights\r
- projected-space \r
- ! remove-inner-faces \r
- ! \r
- eliminate-empty-solids\r
- ] with-pv \r
- ] [ 3drop <space> ] recover\r
- ; inline\r
-\r
-: middle-of-space ( space -- point )\r
- solids>> [ corners>> ] map concat\r
- [ [ ] [ v+ ] map-reduce ] [ length ] bi v/n\r
-;\r
-\r
-! -------------------------------------------------------------\r
-! 3D rendering\r
-! -------------------------------------------------------------\r
-\r
-: face-reference ( face -- halfspace point vect )\r
- [ halfspace>> ] \r
- [ touching-corners>> first ] \r
- [ touching-corners>> second ] tri \r
- over v-\r
-;\r
-\r
-: theta ( v halfspace point vect -- v x )\r
- [ [ over ] dip v- ] dip \r
- [ cross dup norm >float ]\r
- [ v. >float ] \r
- 2bi \r
- fatan2\r
- -rot v. \r
- 0 < [ neg ] when\r
-;\r
-\r
-: ordered-face-points ( face -- corners ) \r
- [ touching-corners>> 1 head ] \r
- [ touching-corners>> 1 tail ] \r
- [ face-reference [ theta ] 3curry ] tri\r
- { } map>assoc sort-values keys \r
- append\r
- ; inline\r
-\r
-: point->GL ( point -- ) gl-vertex ;\r
-: points->GL ( array -- ) do-cycle [ point->GL ] each ;\r
-\r
-: face->GL ( face color -- )\r
- [ ordered-face-points ] dip\r
- [ first3 1.0 glColor4d GL_POLYGON \r
- [ [ point->GL ] each ] do-state ] curry\r
- [ 0 0 0 1 glColor4d GL_LINE_LOOP \r
- [ [ point->GL ] each ] do-state ]\r
- bi\r
- ; inline\r
-\r
-: solid->GL ( solid -- ) \r
- [ faces>> ] \r
- [ color>> ] bi\r
- [ face->GL ] curry each ; inline\r
-\r
-: space->GL ( space -- )\r
- solids>>\r
- [ solid->GL ] each ;\r
-\r
-\r
-\r
-\r
-\r
+++ /dev/null
-! : init-4D-demo ( -- space )\r
-! OK\r
-! espace de dimension 4 et de couleur 0,3 0.3 0.3\r
-<space> \r
- 4 >>dimension\r
- { 0.3 0.3 0.3 } >>ambient-color\r
- { 100 150 100 150 100 150 100 150 } "4cube1" 4cube suffix-solids\r
- { 160 180 160 180 160 180 160 180 } "4cube2" 4cube suffix-solids\r
- <light>\r
- { -100 -100 -100 -100 } >>position\r
- { 0.2 0.7 0.1 } >>color\r
- suffix-lights\r
-! ;\r
-! : init-3D-demo ( -- space )\r
-! OK\r
-! espace de dimension 4 et de couleur 0,3 0.3 0.3\r
-<space> \r
- 3 >>dimension\r
- { 0.3 0.3 0.3 } >>ambient-color\r
- { 100 150 100 150 100 150 } "3cube1" 3cube suffix-solids\r
- ! { -150 -10 -150 -10 -150 -10 -150 -10 } "4cube2" 4cube suffix-solids\r
- <light>\r
- { -100 -100 -100 -100 } >>position\r
- { 0.2 0.7 0.1 } >>color\r
- suffix-lights\r
-! ;\r
-\r
-\r
-: s1 ( -- solid )\r
- <solid> \r
- 2 >>dimension\r
- "s1" >>name\r
- { 1 1 1 } >>color\r
- { 1 -1 -5 } cut-solid \r
- { -1 -1 -21 } cut-solid \r
- { -1 0 -12 } cut-solid \r
- { 1 2 16 } cut-solid\r
-;\r
-: solid1 ( -- solid )\r
- <solid> \r
- 2 >>dimension\r
- "solid1" >>name\r
- { 1 -1 -5 } cut-solid \r
- { -1 -1 -21 } cut-solid \r
- { -1 0 -12 } cut-solid \r
- { 1 2 16 } cut-solid\r
- ensure-adjacencies\r
- \r
-;\r
-: solid2 ( -- solid )\r
- <solid> \r
- 2 >>dimension\r
- "solid2" >>name\r
- { -1 1 -10 } cut-solid \r
- { -1 -1 -28 } cut-solid \r
- { 1 0 13 } cut-solid \r
- ! { 1 2 16 } cut-solid\r
- ensure-adjacencies\r
- \r
-;\r
-\r
-: solid3 ( -- solid )\r
- <solid> \r
- 2 >>dimension\r
- "solid3" >>name\r
- { 1 1 1 } >>color\r
- { 1 0 16 } cut-solid \r
- { -1 0 -36 } cut-solid \r
- { 0 1 1 } cut-solid \r
- { 0 -1 -17 } cut-solid \r
- ! { 1 2 16 } cut-solid\r
- ensure-adjacencies\r
- \r
-\r
-;\r
-\r
-: solid4 ( -- solid )\r
- <solid> \r
- 2 >>dimension\r
- "solid4" >>name\r
- { 1 1 1 } >>color\r
- { 1 0 21 } cut-solid \r
- { -1 0 -36 } cut-solid \r
- { 0 1 1 } cut-solid \r
- { 0 -1 -17 } cut-solid \r
- ensure-adjacencies\r
- \r
-;\r
-\r
-: solid5 ( -- solid )\r
- <solid> \r
- 2 >>dimension\r
- "solid5" >>name\r
- { 1 1 1 } >>color\r
- { 1 0 6 } cut-solid \r
- { -1 0 -17 } cut-solid \r
- { 0 1 17 } cut-solid \r
- { 0 -1 -19 } cut-solid \r
- ensure-adjacencies\r
- \r
-;\r
-\r
-: solid7 ( -- solid )\r
- <solid> \r
- 2 >>dimension\r
- "solid7" >>name\r
- { 1 1 1 } >>color\r
- { 1 0 38 } cut-solid \r
- { 1 -5 -66 } cut-solid \r
- { -2 1 -75 } cut-solid\r
- ensure-adjacencies\r
- \r
-;\r
-\r
-: solid6s ( -- seq )\r
- solid3 clone solid2 clone subtract\r
-;\r
-\r
-: space1 ( -- space )\r
- <space>\r
- 2 >>dimension\r
- ! solid3 suffix-solids\r
- solid1 suffix-solids\r
- solid2 suffix-solids\r
- ! solid6s [ suffix-solids ] each \r
- solid4 suffix-solids\r
- ! solid5 suffix-solids\r
- solid7 suffix-solids\r
- { 1 1 1 } >>ambient-color\r
- <light>\r
- { -100 -100 } >>position\r
- { 0.2 0.7 0.1 } >>color\r
- suffix-lights\r
-;\r
-\r
-: space2 ( -- space )\r
- <space>\r
- 4 >>dimension\r
- ! 4cube suffix-solids\r
- { 1 1 1 } >>ambient-color\r
- <light>\r
- { -100 -100 } >>position\r
- { 0.2 0.7 0.1 } >>color\r
- suffix-lights\r
-\r
- ;\r
-\r
+++ /dev/null
-Jeff Bigot\r
-Greg Ferrar
\ No newline at end of file
+++ /dev/null
-JF Bigot, after Greg Ferrar
\ No newline at end of file
+++ /dev/null
-! Copyright (C) 2008 Jeff Bigot.
-! See http://factorcode.org/license.txt for BSD license.
-USING: arrays help.markup help.syntax kernel sequences ;
-IN: adsoda.combinators
-
-HELP: among
-{ $values
- { "array" array } { "n" "number of value to select" }
- { "array" array }
-}
-{ $description "returns an array containings every possibilities of n choices among a given sequence" } ;
-
-HELP: columnize
-{ $values
- { "array" array }
- { "array" array }
-}
-{ $description "flip a sequence into a sequence of 1 element sequences" } ;
-
-HELP: concat-nth
-{ $values
- { "seq1" sequence } { "seq2" sequence }
- { "seq" sequence }
-}
-{ $description "merges 2 sequences of sequences appending corresponding elements" } ;
-
-HELP: do-cycle
-{ $values
- { "array" array }
- { "array" array }
-}
-{ $description "Copy the first element at the end of the sequence in order to close the cycle." } ;
-
-
-ARTICLE: "adsoda.combinators" "Combinators"
-{ $vocab-link "adsoda.combinators" }
-;
-
-ABOUT: "adsoda.combinators"
+++ /dev/null
-USING: adsoda.combinators\r
-sequences\r
- tools.test \r
- ;\r
-\r
-IN: adsoda.combinators.tests\r
-\r
-\r
-[ { "atoto" "b" "ctoto" } ] [ { "a" "b" "c" } 1 [ "toto" append ] map-but ] \r
- unit-test\r
-\r
+++ /dev/null
-! Copyright (C) 2008 Jeff Bigot\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: kernel arrays sequences fry math combinators ;\r
-\r
-IN: adsoda.combinators\r
-\r
-! : (combinations) ( seq -- seq ) [ 1 tail ] dip combinations ;\r
-\r
-! : prefix-each [ prefix ] curry map ; inline\r
-\r
-! : combinations ( seq n -- seqs )\r
-! {\r
-! { [ dup 0 = ] [ 2drop { { } } ] }\r
-! { [ over empty? ] [ 2drop { } ] }\r
-! { [ t ] [ \r
-! [ [ 1 - (combinations) ] [ drop first ] 2bi prefix-each ]\r
-! [ (combinations) ] 2bi append\r
-! ] }\r
-! } cond ;\r
-\r
-: columnize ( array -- array ) [ 1array ] map ; inline\r
-\r
-: among ( array n -- array )\r
- 2dup swap length \r
- {\r
- { [ over 1 = ] [ 3drop columnize ] }\r
- { [ over 0 = ] [ 2drop 2drop { } ] }\r
- { [ 2dup < ] [ 2drop [ 1 cut ] dip \r
- [ 1 - among [ append ] with map ] \r
- [ among append ] 2bi\r
- ] }\r
- { [ 2dup = ] [ 3drop 1array ] }\r
- { [ 2dup > ] [ 2drop 2drop { } ] } \r
- } cond\r
-;\r
-\r
-: concat-nth ( seq1 seq2 -- seq ) \r
- [ nth append ] curry map-index ;\r
-\r
-: do-cycle ( array -- array ) dup first suffix ;\r
-\r
-: map-but ( seq i quot -- seq )\r
- ! quot : ( seq x -- seq )\r
- '[ _ = [ @ ] unless ] map-index ; inline\r
-\r
+++ /dev/null
-USING: kernel\r
-sequences\r
-namespaces\r
-\r
-math\r
-math.vectors\r
-math.matrices\r
-;\r
-IN: adsoda.solution2\r
-\r
-! -------------------\r
-! correctif solution\r
-! ---------------\r
-SYMBOL: matrix\r
-: MIN-VAL-adsoda ( -- x ) 0.00000001\r
-! 0.000000000001 \r
-;\r
-\r
-: zero? ( x -- ? ) \r
- abs MIN-VAL-adsoda <\r
-;\r
-\r
-! [ number>string string>number ] map \r
-\r
-: with-matrix ( matrix quot -- )\r
- [ swap matrix set call matrix get ] with-scope ; inline\r
-\r
-: nth-row ( row# -- seq ) matrix get nth ;\r
-\r
-: change-row ( row# quot -- seq ) ! row# quot -- | quot: seq -- seq )\r
- matrix get swap change-nth ; inline\r
-\r
-: exchange-rows ( row# row# -- ) matrix get exchange ;\r
-\r
-: rows ( -- n ) matrix get length ;\r
-\r
-: cols ( -- n ) 0 nth-row length ;\r
-\r
-: skip ( i seq quot -- n )\r
- over [ find-from drop ] dip length or ; inline\r
-\r
-: first-col ( row# -- n )\r
- #! First non-zero column\r
- 0 swap nth-row [ zero? not ] skip ;\r
-\r
-: clear-scale ( col# pivot-row i-row -- n )\r
- [ over ] dip nth dup zero? [\r
- 3drop 0\r
- ] [\r
- [ nth dup zero? ] dip swap [\r
- 2drop 0\r
- ] [\r
- swap / neg\r
- ] if\r
- ] if ;\r
-\r
-: (clear-col) ( col# pivot-row i -- )\r
- [ [ clear-scale ] 2keep [ n*v ] dip v+ ] change-row ;\r
-\r
-: rows-from ( row# -- slice )\r
- rows dup <slice> ;\r
-\r
-: clear-col ( col# row# rows -- )\r
- [ nth-row ] dip [ [ 2dup ] dip (clear-col) ] each 2drop ;\r
-\r
-: do-row ( exchange-with row# -- )\r
- [ exchange-rows ] keep\r
- [ first-col ] keep\r
- dup 1 + rows-from clear-col ;\r
-\r
-: find-row ( row# quot -- i elt )\r
- [ rows-from ] dip find ; inline\r
-\r
-: pivot-row ( col# row# -- n )\r
- [ dupd nth-row nth zero? not ] find-row 2nip ;\r
-\r
-: (echelon) ( col# row# -- )\r
- over cols < over rows < and [\r
- 2dup pivot-row [ over do-row 1 + ] when*\r
- [ 1 + ] dip (echelon)\r
- ] [\r
- 2drop\r
- ] if ;\r
-\r
-: echelon ( matrix -- matrix' )\r
- [ 0 0 (echelon) ] with-matrix ;\r
-\r
-: nonzero-rows ( matrix -- matrix' )\r
- [ [ zero? ] all? not ] filter ;\r
-\r
-: null/rank ( matrix -- null rank )\r
- echelon dup length swap nonzero-rows length [ - ] keep ;\r
-\r
-: leading ( seq -- n elt ) [ zero? not ] find ;\r
-\r
-: reduced ( matrix' -- matrix'' )\r
- [\r
- rows <reversed> [\r
- dup nth-row leading drop\r
- dup [ swap dup clear-col ] [ 2drop ] if\r
- ] each\r
- ] with-matrix ;\r
-\r
-: basis-vector ( row col# -- )\r
- [ clone ] dip\r
- [ swap nth neg recip ] 2keep\r
- [ 0 spin set-nth ] 2keep\r
- [ n*v ] dip\r
- matrix get set-nth ;\r
-\r
-: nullspace ( matrix -- seq )\r
- echelon reduced dup empty? [\r
- dup first length identity-matrix [\r
- [\r
- dup leading drop\r
- dup [ basis-vector ] [ 2drop ] if\r
- ] each\r
- ] with-matrix flip nonzero-rows\r
- ] unless ;\r
-\r
-: 1-pivots ( matrix -- matrix )\r
- [ dup leading nip [ recip v*n ] when* ] map ;\r
-\r
-: solution ( matrix -- matrix )\r
- echelon nonzero-rows reduced 1-pivots ;\r
-\r
+++ /dev/null
-A modification of solution to approximate solutions
\ No newline at end of file
+++ /dev/null
-ADSODA : Arbitrary-Dimensional Solid Object Display Algorithm
\ No newline at end of file
+++ /dev/null
-adsoda 4D viewer
\ No newline at end of file
+++ /dev/null
-Jeff Bigot
\ No newline at end of file
+++ /dev/null
-! Copyright (C) 2008 Jeff Bigot.
-! See http://factorcode.org/license.txt for BSD license.
-USING: arrays help.markup help.syntax kernel sequences ;
-IN: adsoda.tools
-
-HELP: 3cube
-{ $values
- { "array" "array" } { "name" "name" }
- { "solid" "solid" }
-}
-{ $description "array : xmin xmax ymin ymax zmin zmax"
-"returns a 3D solid with given limits"
-} ;
-
-HELP: 4cube
-{ $values
- { "array" "array" } { "name" "name" }
- { "solid" "solid" }
-}
-{ $description "array : xmin xmax ymin ymax zmin zmax wmin wmax"
-"returns a 4D solid with given limits"
-} ;
-
-
-HELP: equation-system-for-normal
-{ $values
- { "points" "a list of n points" }
- { "matrix" "matrix" }
-}
-{ $description "From a list of points, return the matrix"
-"to solve in order to find the vector normal to the plan defined by the points" }
-;
-
-HELP: normal-vector
-{ $values
- { "points" "a list of n points" }
- { "v" "a vector" }
-}
-{ $description "From a list of points, returns the vector normal to the plan defined by the points"
-"With n points, creates n-1 vectors and then find a vector orthogonal to every others"
-"returns { f } if a normal vector can not be found" }
-;
-
-HELP: points-to-hyperplane
-{ $values
- { "points" "a list of n points" }
- { "hyperplane" "an hyperplane equation" }
-}
-{ $description "From a list of points, returns the equation of the hyperplan"
-"Finds a normal vector and then translate it so that it includes one of the points"
-
-}
-;
-
-ARTICLE: "adsoda.tools" "Tools"
-{ $vocab-link "adsoda.tools" }
-"Tools to help in building an " { $vocab-link "adsoda" } "-space"
-;
-
-ABOUT: "adsoda.tools"
-
-
+++ /dev/null
-! Copyright (C) 2008 Jeff Bigot\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: \r
-adsoda.tools\r
-tools.test\r
-;\r
-\r
-IN: adsoda.tools.tests\r
-\r
-\r
- [ { 1 0 } ] [ { { 0 0 } { 0 1 } } normal-vector ] unit-test\r
- [ f ] [ { { 0 0 } { 0 0 } } normal-vector ] unit-test\r
-\r
- [ { 1/2 1/2 1+1/2 } ] [ { { 1 2 } { 2 1 } } points-to-hyperplane ] unit-test\r
+++ /dev/null
-! Copyright (C) 2008 Jeff Bigot\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: \r
-kernel\r
-sequences\r
-math\r
-accessors\r
-adsoda\r
-math.vectors \r
-math.matrices\r
-bunny.model\r
-io.encodings.ascii\r
-io.files\r
-sequences.deep\r
-combinators\r
-adsoda.combinators\r
-fry\r
-io.files.temp\r
-grouping\r
-;\r
-\r
-IN: adsoda.tools\r
-\r
-\r
-\r
-\r
-\r
-! ---------------------------------\r
-: coord-min ( x array -- array ) swap suffix ;\r
-: coord-max ( x array -- array ) swap neg suffix ;\r
-\r
-: 4cube ( array name -- solid )\r
-! array : xmin xmax ymin ymax zmin zmax wmin wmax\r
- <solid> \r
- 4 >>dimension\r
- swap >>name\r
- swap\r
- { \r
- [ { 1 0 0 0 } coord-min ] [ { -1 0 0 0 } coord-max ] \r
- [ { 0 1 0 0 } coord-min ] [ { 0 -1 0 0 } coord-max ]\r
- [ { 0 0 1 0 } coord-min ] [ { 0 0 -1 0 } coord-max ] \r
- [ { 0 0 0 1 } coord-min ] [ { 0 0 0 -1 } coord-max ]\r
- }\r
- [ curry call ] 2map \r
- [ cut-solid ] each \r
- ensure-adjacencies\r
- \r
-; inline\r
-\r
-: 3cube ( array name -- solid )\r
-! array : xmin xmax ymin ymax zmin zmax wmin wmax\r
- <solid> \r
- 3 >>dimension\r
- swap >>name\r
- swap\r
- { \r
- [ { 1 0 0 } coord-min ] [ { -1 0 0 } coord-max ] \r
- [ { 0 1 0 } coord-min ] [ { 0 -1 0 } coord-max ]\r
- [ { 0 0 1 } coord-min ] [ { 0 0 -1 } coord-max ] \r
- }\r
- [ curry call ] 2map \r
- [ cut-solid ] each \r
- ensure-adjacencies\r
- \r
-; inline\r
-\r
-\r
-: equation-system-for-normal ( points -- matrix )\r
- unclip [ v- 0 suffix ] curry map\r
- dup first [ drop 1 ] map suffix\r
-;\r
-\r
-: normal-vector ( points -- v ) \r
- equation-system-for-normal\r
- intersect-hyperplanes ;\r
-\r
-: points-to-hyperplane ( points -- hyperplane )\r
- [ normal-vector 0 suffix ] [ first ] bi\r
- translate ;\r
-\r
-: refs-to-points ( points faces -- faces )\r
- [ swap [ nth 10 v*n { 100 100 100 } v+ ] curry map ] \r
- with map\r
-;\r
-! V{ { 0.1 0.2 } { 1.1 1.3 } } V{ { 1 0 } { 0 1 } }\r
-! V{ { { 1.1 1.3 } { 0.1 0.2 } } { { 0.1 0.2 } { 1.1 1.3 } } }\r
-\r
-: ply-model-path ( -- path )\r
-\r
-! "bun_zipper.ply" \r
-"screw2.ply"\r
-temp-file \r
-;\r
-\r
-: read-bunny-model ( -- v )\r
-ply-model-path ascii [ parse-model ] with-file-reader\r
-\r
-refs-to-points\r
-;\r
-\r
-: 3points-to-normal ( seq -- v )\r
- unclip [ v- ] curry map first2 cross normalize\r
-;\r
-: 2-faces-to-prism ( seq seq -- seq )\r
- 2dup\r
- [ do-cycle 2 clump ] bi@ concat-nth \r
- ! 3 faces rectangulaires\r
- swap prefix\r
- swap prefix\r
-; \r
-\r
-: Xpoints-to-prisme ( seq height -- cube )\r
- ! from 3 points gives a list of faces representing \r
- ! a cube of height "height"\r
- ! and of based on the three points\r
- ! a face is a group of 3 or mode points. \r
- [ dup dup 3points-to-normal ] dip \r
- v*n [ v+ ] curry map ! 2 eme face triangulaire \r
- 2-faces-to-prism \r
-\r
-! [ dup number? [ 1 + ] when ] deep-map\r
-! dup keep \r
-;\r
-\r
-\r
-: Xpoints-to-plane4D ( seq x y -- 4Dplane )\r
- ! from 3 points gives a list of faces representing \r
- ! a cube in 4th dim\r
- ! from x to y (height = y-x)\r
- ! and of based on the X points\r
- ! a face is a group of 3 or mode points. \r
- '[ [ [ _ suffix ] map ] [ [ _ suffix ] map ] bi ] call\r
- 2-faces-to-prism\r
-;\r
-\r
-: 3pointsfaces-to-3Dsolidfaces ( seq -- seq )\r
- [ 1 Xpoints-to-prisme [ 100 \r
- 110 Xpoints-to-plane4D ] map concat ] map \r
-\r
-;\r
-\r
-: test-figure ( -- solid )\r
- <solid> \r
- 2 >>dimension\r
- { 1 -1 -5 } cut-solid \r
- { -1 -1 -21 } cut-solid \r
- { -1 0 -12 } cut-solid \r
- { 1 2 16 } cut-solid\r
-;\r
-\r
--- /dev/null
+! Copyright (C) 2008 Jeff Bigot\r
+! See http://factorcode.org/license.txt for BSD license.\r
+USING: help.markup help.syntax ;\r
+IN: adsoda\r
+\r
+! --------------------------------------------------------------\r
+! faces\r
+! --------------------------------------------------------------\r
+ARTICLE: "face-page" "Face in ADSODA"\r
+"explanation of faces"\r
+$nl\r
+"link to functions" $nl\r
+"what is an halfspace" $nl\r
+"halfspace touching-corners adjacent-faces" $nl\r
+"touching-corners list of pointers to the corners which touch this face" $nl\r
+"adjacent-faces list of pointers to the faces which touch this face"\r
+{ $subsections\r
+ face\r
+ <face>\r
+}\r
+"test relative position"\r
+{ $subsections\r
+ point-inside-or-on-face?\r
+ point-inside-face?\r
+}\r
+"handling face"\r
+{ $subsections\r
+ flip-face\r
+ face-translate\r
+ face-transform\r
+}\r
+\r
+;\r
+\r
+HELP: face\r
+{ $class-description "a face is defined by"\r
+{ $list "halfspace equation" }\r
+{ $list "list of touching corners" }\r
+{ $list "list of adjacent faces" }\r
+$nl\r
+"Touching corners and adjacent faces are defined by algorithm thanks to other faces of the solid"\r
+}\r
+\r
+\r
+;\r
+HELP: <face> \r
+{ $values { "v" "an halfspace equation" } { "tuple" "a face" } } ;\r
+HELP: flip-face \r
+{ $values { "face" "a face" } { "face" "flipped face" } }\r
+{ $description "change the orientation of a face" }\r
+;\r
+\r
+HELP: face-translate \r
+{ $values { "face" "a face" } { "v" "a vector" } }\r
+{ $description \r
+"translate a face following a vector"\r
+$nl\r
+"a translation of an halfspace doesn't change the normal vector. this word just compute the new constant term" }\r
+\r
+ \r
+ ;\r
+HELP: face-transform \r
+{ $values { "face" "a face" } { "m" "a transformation matrix" } }\r
+{ $description "compute the transformation of a face using a transformation matrix" }\r
+ \r
+ ;\r
+! --------------------------------\r
+! solid\r
+! --------------------------------------------------------------\r
+ARTICLE: "solid-page" "Solid in ADSODA"\r
+"explanation of solids"\r
+$nl\r
+"link to functions"\r
+{ $subsections\r
+ solid\r
+ <solid>\r
+}\r
+"test relative position"\r
+{ $subsections\r
+ point-inside-solid?\r
+ point-inside-or-on-solid?\r
+}\r
+"playing with faces and solids"\r
+{ $subsections\r
+ add-face\r
+ cut-solid\r
+ slice-solid\r
+}\r
+"solid handling"\r
+{ $subsections\r
+ solid-project\r
+ solid-translate\r
+ solid-transform\r
+ subtract\r
+ get-silhouette \r
+ solid=\r
+}\r
+;\r
+\r
+HELP: solid \r
+{ $class-description "dimension" $nl "silhouettes" $nl "faces" $nl "corners" $nl "adjacencies-valid" $nl "color" $nl "name" \r
+}\r
+;\r
+\r
+HELP: add-face \r
+{ $values { "solid" "a solid" } { "face" "a face" } }\r
+{ $description "reshape a solid with a face. The face truncate the solid." } ;\r
+\r
+HELP: cut-solid\r
+{ $values { "solid" "a solid" } { "halfspace" "an halfspace" } }\r
+{ $description "like add-face but just with halfspace equation" } ;\r
+\r
+HELP: slice-solid\r
+{ $values { "solid" "a solid" } { "face" "a face" } { "solid1" "the outer part of the former solid" } { "solid2" "the inner part of the former solid" } }\r
+{ $description "cut a solid into two parts. The face acts like a knife"\r
+} ;\r
+\r
+\r
+HELP: solid-project\r
+{ $values { "lights" "lights" } { "ambient" "ambient" } { "solid" "solid" } { "solids" "projection of solid" } }\r
+{ $description "Project the solid using pv vector" \r
+$nl\r
+"TODO: explain how to use lights"\r
+} ;\r
+\r
+HELP: solid-translate \r
+{ $values { "solid" "a solid" } { "v" "translating vector" } }\r
+{ $description "Translate a solid using a vector" \r
+$nl\r
+"v and solid must have the same dimension "\r
+} ;\r
+\r
+HELP: solid-transform \r
+{ $values { "solid" "a solid" } { "m" "transformation matrix" } }\r
+{ $description "Transform a solid using a matrix"\r
+$nl\r
+"v and solid must have the same dimension "\r
+} ;\r
+\r
+HELP: subtract \r
+{ $values { "solid1" "initial shape" } { "solid2" "shape to remove" } { "solids" "resulting shape" } }\r
+{ $description "Substract solid2 from solid1" } ;\r
+\r
+\r
+! --------------------------------------------------------------\r
+! space \r
+! --------------------------------------------------------------\r
+ARTICLE: "space-page" "Space in ADSODA"\r
+"A space is a collection of solids and lights."\r
+$nl\r
+"link to functions"\r
+$nl\r
+"Defining words"\r
+{ $subsections\r
+ space\r
+ <space>\r
+ suffix-solids \r
+ suffix-lights\r
+ clear-space-solids \r
+ describe-space\r
+}\r
+\r
+\r
+"Handling space"\r
+{ $subsections\r
+ space-ensure-solids\r
+ eliminate-empty-solids\r
+ space-transform\r
+ space-translate\r
+ remove-hidden-solids\r
+ space-project\r
+}\r
+\r
+\r
+;\r
+\r
+HELP: space \r
+{ $class-description \r
+"dimension" $nl " solids" $nl " ambient-color" $nl "lights" \r
+}\r
+;\r
+\r
+HELP: suffix-solids \r
+"( space solid -- space )"\r
+{ $values { "space" "a space" } { "solid" "a solid to add" } }\r
+{ $description "Add solid to space definition" } ;\r
+\r
+HELP: suffix-lights \r
+"( space light -- space ) "\r
+{ $values { "space" "a space" } { "light" "a light to add" } }\r
+{ $description "Add a light to space definition" } ;\r
+\r
+HELP: clear-space-solids \r
+"( space -- space )" \r
+{ $values { "space" "a space" } }\r
+{ $description "remove all solids in space" } ;\r
+\r
+HELP: space-ensure-solids \r
+{ $values { "space" "a space" } }\r
+{ $description "rebuild corners of all solids in space" } ;\r
+\r
+\r
+\r
+HELP: space-transform \r
+" ( space m -- space )" \r
+{ $values { "space" "a space" } { "m" "a matrix" } }\r
+{ $description "Transform a space using a matrix" } ;\r
+\r
+HELP: space-translate \r
+{ $values { "space" "a space" } { "v" "a vector" } }\r
+{ $description "Translate a space following a vector" } ;\r
+\r
+HELP: describe-space " ( space -- )"\r
+{ $values { "space" "a space" } }\r
+{ $description "return a description of space" } ;\r
+\r
+HELP: space-project \r
+{ $values { "space" "a space" } { "i" "an integer" } }\r
+{ $description "Project a space along ith coordinate" } ;\r
+\r
+! --------------------------------------------------------------\r
+! 3D rendering\r
+! --------------------------------------------------------------\r
+ARTICLE: "3D-rendering-page" "The 3D rendering in ADSODA"\r
+"explanation of 3D rendering"\r
+$nl\r
+"link to functions"\r
+{ $subsections\r
+ face->GL\r
+ solid->GL\r
+ space->GL\r
+}\r
+\r
+;\r
+\r
+HELP: face->GL \r
+{ $values { "face" "a face" } { "color" "3 3 values array" } }\r
+{ $description "display a face" } ;\r
+\r
+HELP: solid->GL \r
+{ $values { "solid" "a solid" } }\r
+{ $description "display a solid" } ;\r
+\r
+HELP: space->GL \r
+{ $values { "space" "a space" } }\r
+{ $description "display a space" } ;\r
+\r
+! --------------------------------------------------------------\r
+! light\r
+! --------------------------------------------------------------\r
+\r
+ARTICLE: "light-page" "Light in ADSODA"\r
+"explanation of light"\r
+$nl\r
+"link to functions"\r
+;\r
+\r
+ARTICLE: { "adsoda" "light" } "ADSODA : lights"\r
+{ $code """\r
+! HELP: light position color\r
+! <light> ( -- tuple ) light new ;\r
+! light est un vecteur avec 3 variables pour les couleurs\n\r
+ void Light::Apply(Vector& normal, double &cRed, double &cGreen, double &cBlue)\n\r
+ { \n\r
+ // Dot the light direction with the normalized normal of Face.\r
+ register double intensity = -(normal * (*this));\r
+ // Face is a backface, from light's perspective\r
+ if (intensity < 0)\r
+ return;\r
+ \r
+ // Add the intensity componentwise\r
+ cRed += red * intensity;\r
+ cGreen += green * intensity;\r
+ cBlue += blue * intensity;\r
+ // Clip to unit range\r
+ if (cRed > 1.0) cRed = 1.0;\r
+ if (cGreen > 1.0) cGreen = 1.0;\r
+ if (cBlue > 1.0) cBlue = 1.0;\r
+""" }\r
+;\r
+\r
+\r
+\r
+ARTICLE: { "adsoda" "halfspace" } "ADSODA : halfspace"\r
+" defined by the concatenation of the normal vector and a constant" \r
+ ;\r
+\r
+\r
+\r
+ARTICLE: "adsoda-main-page" "ADSODA : Arbitrary-Dimensional Solid Object Display Algorithm"\r
+"multidimensional handler :" \r
+$nl\r
+"design a solid using face delimitations. Only works on convex shapes"\r
+$nl\r
+{ $emphasis "written in C++ by Greg Ferrar" }\r
+$nl\r
+"full explanation on adsoda page at " { $url "http://www.flowerfire.com/ADSODA/" }\r
+$nl\r
+"Useful words are describe on the following pages: "\r
+{ $subsections\r
+ "face-page"\r
+ "solid-page"\r
+ "space-page"\r
+ "light-page"\r
+ "3D-rendering-page"\r
+} ;\r
+\r
+ABOUT: "adsoda-main-page"\r
--- /dev/null
+USING: adsoda\r
+kernel\r
+math\r
+accessors\r
+sequences\r
+ adsoda.solution2\r
+ fry\r
+ tools.test \r
+ arrays ;\r
+\r
+IN: adsoda.tests\r
+\r
+\r
+\r
+: s1 ( -- solid )\r
+ <solid> \r
+ 2 >>dimension\r
+ "s1" >>name\r
+ { 1 1 1 } >>color\r
+ { 1 -1 -5 } cut-solid \r
+ { -1 -1 -21 } cut-solid \r
+ { -1 0 -12 } cut-solid \r
+ { 1 2 16 } cut-solid\r
+;\r
+: solid1 ( -- solid )\r
+ <solid> \r
+ 2 >>dimension\r
+ "solid1" >>name\r
+ { 1 -1 -5 } cut-solid \r
+ { -1 -1 -21 } cut-solid \r
+ { -1 0 -12 } cut-solid \r
+ { 1 2 16 } cut-solid\r
+ ensure-adjacencies\r
+ \r
+;\r
+: solid2 ( -- solid )\r
+ <solid> \r
+ 2 >>dimension\r
+ "solid2" >>name\r
+ { -1 1 -10 } cut-solid \r
+ { -1 -1 -28 } cut-solid \r
+ { 1 0 13 } cut-solid \r
+ ! { 1 2 16 } cut-solid\r
+ ensure-adjacencies\r
+ \r
+;\r
+\r
+: solid3 ( -- solid )\r
+ <solid> \r
+ 2 >>dimension\r
+ "solid3" >>name\r
+ { 1 1 1 } >>color\r
+ { 1 0 16 } cut-solid \r
+ { -1 0 -36 } cut-solid \r
+ { 0 1 1 } cut-solid \r
+ { 0 -1 -17 } cut-solid \r
+ ! { 1 2 16 } cut-solid\r
+ ensure-adjacencies\r
+ \r
+\r
+;\r
+\r
+: solid4 ( -- solid )\r
+ <solid> \r
+ 2 >>dimension\r
+ "solid4" >>name\r
+ { 1 1 1 } >>color\r
+ { 1 0 21 } cut-solid \r
+ { -1 0 -36 } cut-solid \r
+ { 0 1 1 } cut-solid \r
+ { 0 -1 -17 } cut-solid \r
+ ensure-adjacencies\r
+ \r
+;\r
+\r
+: solid5 ( -- solid )\r
+ <solid> \r
+ 2 >>dimension\r
+ "solid5" >>name\r
+ { 1 1 1 } >>color\r
+ { 1 0 6 } cut-solid \r
+ { -1 0 -17 } cut-solid \r
+ { 0 1 17 } cut-solid \r
+ { 0 -1 -19 } cut-solid \r
+ ensure-adjacencies\r
+ \r
+;\r
+\r
+: solid7 ( -- solid )\r
+ <solid> \r
+ 2 >>dimension\r
+ "solid7" >>name\r
+ { 1 1 1 } >>color\r
+ { 1 0 38 } cut-solid \r
+ { 1 -5 -66 } cut-solid \r
+ { -2 1 -75 } cut-solid\r
+ ensure-adjacencies\r
+ \r
+;\r
+\r
+: solid6s ( -- seq )\r
+ solid3 clone solid2 clone subtract\r
+;\r
+\r
+: space1 ( -- space )\r
+ <space>\r
+ 2 >>dimension\r
+ ! solid3 suffix-solids\r
+ solid1 suffix-solids\r
+ solid2 suffix-solids\r
+ ! solid6s [ suffix-solids ] each \r
+ solid4 suffix-solids\r
+ ! solid5 suffix-solids\r
+ solid7 suffix-solids\r
+ { 1 1 1 } >>ambient-color\r
+ <light>\r
+ { -100 -100 } >>position\r
+ { 0.2 0.7 0.1 } >>color\r
+ suffix-lights\r
+;\r
+\r
+: space2 ( -- space )\r
+ <space>\r
+ 4 >>dimension\r
+ ! 4cube suffix-solids\r
+ { 1 1 1 } >>ambient-color\r
+ <light>\r
+ { -100 -100 } >>position\r
+ { 0.2 0.7 0.1 } >>color\r
+ suffix-lights\r
+\r
+ ;\r
+\r
+\r
+\r
+! {\r
+! { 1 0 0 0 }\r
+! { 0 1 0 0 }\r
+! { 0 0 0.984807753012208 -0.1736481776669303 }\r
+! { 0 0 0.1736481776669303 0.984807753012208 }\r
+! }\r
+\r
+! ------------------------------------------------------------\r
+! constant+\r
+[ { 1 2 5 } ] [ { 1 2 3 } 2 constant+ ] unit-test\r
+\r
+! ------------------------------------------------------------\r
+! translate\r
+[ { 1 -1 0 } ] [ { 1 -1 -5 } { 3 -2 } translate ] unit-test\r
+\r
+! ------------------------------------------------------------\r
+! transform\r
+[ { -1 -1 -5 21.0 } ] [ { -1 -1 -5 21 }\r
+ { { 1 0 0 }\r
+ { 0 1 0 }\r
+ { 0 0 1 }\r
+ } transform \r
+] unit-test\r
+\r
+! ------------------------------------------------------------\r
+! compare-nleft-to-identity-matrix\r
+[ t ] [ \r
+ { \r
+ { 1 0 0 1232 } \r
+ { 0 1 0 0 321 } \r
+ { 0 0 1 0 } } \r
+ 3 compare-nleft-to-identity-matrix \r
+] unit-test\r
+\r
+[ f ] [ \r
+ { { 1 0 0 } { 0 1 0 } { 0 0 0 } } \r
+ 3 compare-nleft-to-identity-matrix \r
+] unit-test\r
+\r
+[ f ] [ \r
+ { { 2 0 0 } { 0 1 0 } { 0 0 1 } } \r
+ 3 compare-nleft-to-identity-matrix \r
+] unit-test\r
+! ------------------------------------------------------------\r
+[ t ] [ \r
+ { { 1 0 0 }\r
+ { 0 1 0 }\r
+ { 0 0 1 } } 3 valid-solution? \r
+] unit-test\r
+\r
+[ f ] [ \r
+ { { 1 0 0 1 }\r
+ { 0 0 0 1 }\r
+ { 0 0 1 0 } } 3 valid-solution? \r
+] unit-test\r
+\r
+[ f ] [ \r
+ { { 1 0 0 1 }\r
+ { 0 0 0 1 } } 3 valid-solution? \r
+] unit-test\r
+\r
+[ f ] [ \r
+ { { 1 0 0 1 }\r
+ { 0 0 0 1 }\r
+ { 0 0 1 0 } } 2 valid-solution? \r
+] unit-test\r
+\r
+! ------------------------------------------------------------\r
+[ 3 ] [ { 1 2 3 } last ] unit-test \r
+\r
+[ { 1 2 5 } ] [ { 1 2 3 } dup [ 2 + ] change-last ] unit-test \r
+\r
+! ------------------------------------------------------------\r
+! position-point \r
+[ 0 ] [ \r
+ { 1 -1 -5 } { 2 7 } position-point \r
+] unit-test\r
+\r
+! ------------------------------------------------------------\r
+\r
+! transform\r
+! TODO construire un exemple\r
+\r
+\r
+! ------------------------------------------------------------\r
+! slice-solid \r
+\r
+! ------------------------------------------------------------\r
+! solve-equation \r
+! deux cas de tests, avec solution et sans solution\r
+\r
+[ { 2 7 } ] \r
+[ { { 1 -1 -5 } { 1 2 16 } } intersect-hyperplanes ] \r
+unit-test\r
+\r
+[ f ] \r
+[ { { 1 -1 -5 } { 1 2 16 } { -1 -1 -21 } } intersect-hyperplanes ]\r
+unit-test\r
+\r
+[ f ] \r
+[ { { 1 0 -5 } { 1 0 16 } } intersect-hyperplanes ]\r
+unit-test\r
+\r
+! ------------------------------------------------------------\r
+! point-inside-halfspace\r
+[ t ] [ { 1 -1 -5 } { 0 0 } point-inside-halfspace? ] \r
+unit-test\r
+[ f ] [ { 1 -1 -5 } { 8 13 } point-inside-halfspace? ] \r
+unit-test\r
+[ t ] [ { 1 -1 -5 } { 8 13 } point-inside-or-on-halfspace? ] \r
+unit-test\r
+\r
+\r
+! ------------------------------\r
+! order solid\r
+\r
+[ 1 ] [ 0 >pv solid1 solid2 order-solid ] unit-test\r
+[ -1 ] [ 0 >pv solid2 solid1 order-solid ] unit-test\r
+[ f ] [ 1 >pv solid1 solid2 order-solid ] unit-test\r
+[ f ] [ 1 >pv solid2 solid1 order-solid ] unit-test\r
+\r
+\r
+! clip-solid\r
+[ { { 13 15 } { 15 13 } { 13 13 } } ]\r
+ [ 0 >pv solid2 solid1 clip-solid first corners>> ] unit-test\r
+\r
+solid1 corners>> '[ _ ]\r
+ [ 0 >pv solid1 solid1 clip-solid first corners>> ] unit-test\r
+\r
+solid1 corners>> '[ _ ]\r
+ [ 0 >pv solid1 solid2 clip-solid first corners>> ] unit-test\r
+\r
+solid1 corners>> '[ _ ]\r
+ [ 1 >pv solid1 solid2 clip-solid first corners>> ] unit-test\r
+solid2 corners>> '[ _ ]\r
+ [ 1 >pv solid2 solid1 clip-solid first corners>> ] unit-test\r
+\r
+!\r
+[\r
+ {\r
+ { { 13 15 } { 15 13 } { 13 13 } }\r
+ { { 16 17 } { 16 13 } { 36 17 } { 36 13 } }\r
+ { { 16 1 } { 16 2 } { 36 1 } { 36 2 } }\r
+ }\r
+] [ 0 >pv solid2 solid3 2array \r
+ solid1 (solids-silhouette-subtract) \r
+ [ corners>> ] map\r
+ ] unit-test\r
+\r
+\r
+[\r
+{\r
+ { { 8 13 } { 2 7 } { 12 9 } { 12 2 } }\r
+ { { 13 15 } { 15 13 } { 13 13 } }\r
+ { { 16 17 } { 16 15 } { 36 17 } { 36 15 } }\r
+ { { 16 1 } { 16 2 } { 36 1 } { 36 2 } }\r
+}\r
+] [ \r
+ 0 >pv <space> solid1 suffix-solids \r
+ solid2 suffix-solids \r
+ solid3 suffix-solids\r
+ remove-hidden-solids\r
+ solids>> [ corners>> ] map\r
+] unit-test\r
+\r
+! { }\r
+! { }\r
+! <light> { 0.2 0.3 0.4 } >>color { 1 -1 1 } >>direction suffix\r
+! <light> { 0.4 0.3 0.1 } >>color { -1 -1 -1 } >>direction suffix\r
+! suffix \r
+! { 0.1 0.1 0.1 } suffix ! ambient color\r
+! { 0.23 0.32 0.17 } suffix ! solid color\r
+! solid3 faces>> first \r
+\r
+! enlight-projection\r
--- /dev/null
+! Copyright (C) 2008 Jeff Bigot\r
+! See http://factorcode.org/license.txt for BSD license.\r
+USING: accessors\r
+arrays \r
+assocs\r
+combinators\r
+kernel \r
+fry\r
+math \r
+math.constants\r
+math.functions\r
+math.libm\r
+math.order\r
+math.vectors \r
+math.matrices \r
+math.parser\r
+namespaces\r
+prettyprint\r
+sequences\r
+sequences.deep\r
+sets\r
+slots\r
+sorting\r
+tools.time\r
+vars\r
+continuations\r
+words\r
+opengl\r
+opengl.gl\r
+colors\r
+adsoda.solution2\r
+adsoda.combinators\r
+opengl.demo-support\r
+values\r
+tools.walker\r
+;\r
+\r
+IN: adsoda\r
+\r
+DEFER: combinations\r
+VAR: pv\r
+\r
+\r
+! -------------------------------------------------------------\r
+! global values\r
+VALUE: remove-hidden-solids?\r
+VALUE: VERY-SMALL-NUM\r
+VALUE: ZERO-VALUE\r
+VALUE: MAX-FACE-PER-CORNER\r
+\r
+t to: remove-hidden-solids?\r
+0.0000001 to: VERY-SMALL-NUM\r
+0.0000001 to: ZERO-VALUE\r
+4 to: MAX-FACE-PER-CORNER\r
+! -------------------------------------------------------------\r
+! sequence complement\r
+\r
+: with-pv ( i quot -- ) [ swap >pv call ] with-scope ; inline\r
+\r
+: dimension ( array -- x ) length 1 - ; inline \r
+: change-last ( seq quot -- ) \r
+ [ [ dimension ] keep ] dip change-nth ; inline\r
+\r
+! -------------------------------------------------------------\r
+! light\r
+! -------------------------------------------------------------\r
+\r
+TUPLE: light name { direction array } color ;\r
+: <light> ( -- tuple ) light new ;\r
+\r
+! -------------------------------------------------------------\r
+! halfspace manipulation\r
+! -------------------------------------------------------------\r
+\r
+: constant+ ( v x -- w ) '[ [ _ + ] change-last ] keep ;\r
+: translate ( u v -- w ) dupd v* sum constant+ ; \r
+\r
+: transform ( u matrix -- w )\r
+ [ swap m.v ] 2keep ! compute new normal vector \r
+ [\r
+ [ [ abs ZERO-VALUE > ] find ] keep \r
+ ! find a point on the frontier\r
+ ! be sure it's not null vector\r
+ last ! get constant\r
+ swap /f neg swap ! intercept value\r
+ ] dip \r
+ flip \r
+ nth\r
+ [ * ] with map ! apply intercep value\r
+ over v*\r
+ sum neg\r
+ suffix ! add value as constant at the end of equation\r
+;\r
+\r
+: position-point ( halfspace v -- x ) \r
+ -1 suffix v* sum ; inline\r
+: point-inside-halfspace? ( halfspace v -- ? ) \r
+ position-point VERY-SMALL-NUM > ; \r
+: point-inside-or-on-halfspace? ( halfspace v -- ? ) \r
+ position-point VERY-SMALL-NUM neg > ;\r
+: project-vector ( seq -- seq ) \r
+ pv> [ head ] [ 1 + tail ] 2bi append ; \r
+: get-intersection ( matrice -- seq ) \r
+ [ 1 tail* ] map flip first ;\r
+\r
+: islenght=? ( seq n -- seq n ? ) 2dup [ length ] [ = ] bi* ;\r
+\r
+: compare-nleft-to-identity-matrix ( seq n -- ? ) \r
+ [ [ head ] curry map ] keep identity-matrix m- \r
+ flatten\r
+ [ abs ZERO-VALUE < ] all?\r
+;\r
+\r
+: valid-solution? ( matrice n -- ? )\r
+ islenght=?\r
+ [ compare-nleft-to-identity-matrix ] \r
+ [ 2drop f ] if ; inline\r
+\r
+: intersect-hyperplanes ( matrice -- seq )\r
+ [ solution dup ] [ first dimension ] bi\r
+ valid-solution? [ get-intersection ] [ drop f ] if ;\r
+\r
+! -------------------------------------------------------------\r
+! faces\r
+! -------------------------------------------------------------\r
+\r
+TUPLE: face { halfspace array } \r
+ touching-corners adjacent-faces ;\r
+: <face> ( v -- tuple ) face new swap >>halfspace ;\r
+: flip-face ( face -- face ) [ vneg ] change-halfspace ;\r
+: erase-face-touching-corners ( face -- face ) \r
+ f >>touching-corners ;\r
+: erase-face-adjacent-faces ( face -- face ) \r
+ f >>adjacent-faces ;\r
+: faces-intersection ( faces -- v ) \r
+ [ halfspace>> ] map intersect-hyperplanes ;\r
+: face-translate ( face v -- face ) \r
+ [ translate ] curry change-halfspace ; inline\r
+: face-transform ( face m -- face )\r
+ [ transform ] curry change-halfspace ; inline\r
+: face-orientation ( face -- x ) pv> swap halfspace>> nth sgn ;\r
+: backface? ( face -- face ? ) dup face-orientation 0 <= ;\r
+: pv-factor ( face -- f face ) \r
+ halfspace>> [ pv> swap nth [ * ] curry ] keep ; inline\r
+: suffix-touching-corner ( face corner -- face ) \r
+ [ suffix ] curry change-touching-corners ; inline\r
+: real-face? ( face -- ? )\r
+ [ touching-corners>> length ] \r
+ [ halfspace>> dimension ] bi >= ;\r
+\r
+: (add-to-adjacent-faces) ( face face -- face )\r
+ over adjacent-faces>> 2dup member?\r
+ [ 2drop ] [ swap suffix >>adjacent-faces ] if ;\r
+\r
+: add-to-adjacent-faces ( face face -- face )\r
+ 2dup = [ drop ] [ (add-to-adjacent-faces) ] if ;\r
+\r
+: update-adjacent-faces ( faces corner -- )\r
+ '[ [ _ suffix-touching-corner drop ] each ] keep \r
+ 2 among [ \r
+ [ first ] keep second \r
+ [ add-to-adjacent-faces drop ] 2keep \r
+ swap add-to-adjacent-faces drop \r
+ ] each ; inline\r
+\r
+: face-project-dim ( face -- x ) halfspace>> length 2 - ;\r
+\r
+: apply-light ( color light normal -- u )\r
+ over direction>> v. \r
+ neg dup 0 > \r
+ [ \r
+ [ color>> swap ] dip \r
+ [ * ] curry map v+ \r
+ [ 1 min ] map \r
+ ] \r
+ [ 2drop ] \r
+ if\r
+;\r
+\r
+: enlight-projection ( array face -- color )\r
+ ! array = lights + ambient color\r
+ [ [ third ] [ second ] [ first ] tri ]\r
+ [ halfspace>> project-vector normalize ] bi*\r
+ [ apply-light ] curry each\r
+ v*\r
+;\r
+\r
+: (intersection-into-face) ( face-init face-adja quot -- face )\r
+ [\r
+ [ [ pv-factor ] bi@ \r
+ roll \r
+ [ map ] 2bi@\r
+ v-\r
+ ] 2keep\r
+ [ touching-corners>> ] bi@\r
+ [ swap [ = ] curry find nip f = ] curry find nip\r
+ ] dip over\r
+ [\r
+ call\r
+ dupd\r
+ point-inside-halfspace? [ vneg ] unless \r
+ <face> \r
+ ] [ 3drop f ] if \r
+ ; inline\r
+\r
+: intersection-into-face ( face-init face-adja -- face )\r
+ [ [ project-vector ] bi@ ] (intersection-into-face) ;\r
+\r
+: intersection-into-silhouette-face ( face-init face-adja -- face )\r
+ [ ] (intersection-into-face) ;\r
+\r
+: intersections-into-faces ( face -- faces )\r
+ clone dup \r
+ adjacent-faces>> [ intersection-into-face ] with map \r
+ [ ] filter ;\r
+\r
+: (face-silhouette) ( face -- faces )\r
+ clone dup adjacent-faces>>\r
+ [ backface?\r
+ [ intersection-into-silhouette-face ] [ 2drop f ] if \r
+ ] with map \r
+ [ ] filter\r
+; inline\r
+\r
+: face-silhouette ( face -- faces ) \r
+ backface? [ drop f ] [ (face-silhouette) ] if ;\r
+\r
+! --------------------------------\r
+! solid\r
+! -------------------------------------------------------------\r
+TUPLE: solid dimension silhouettes \r
+ faces corners adjacencies-valid color name ;\r
+\r
+: <solid> ( -- tuple ) solid new ;\r
+\r
+: suffix-silhouettes ( solid silhouette -- solid ) \r
+ [ suffix ] curry change-silhouettes ;\r
+\r
+: suffix-face ( solid face -- solid ) \r
+ [ suffix ] curry change-faces ;\r
+: suffix-corner ( solid corner -- solid ) \r
+ [ suffix ] curry change-corners ; \r
+: erase-solid-corners ( solid -- solid ) f >>corners ;\r
+\r
+: erase-silhouettes ( solid -- solid ) \r
+ dup dimension>> f <array> >>silhouettes ;\r
+: filter-real-faces ( solid -- solid ) \r
+ [ [ real-face? ] filter ] change-faces ;\r
+: initiate-solid-from-face ( face -- solid ) \r
+ face-project-dim <solid> swap >>dimension ;\r
+\r
+: erase-old-adjacencies ( solid -- solid )\r
+ erase-solid-corners\r
+ [ dup [ erase-face-touching-corners \r
+ erase-face-adjacent-faces drop ] each ]\r
+ change-faces ;\r
+\r
+: point-inside-or-on-face? ( face v -- ? ) \r
+ [ halfspace>> ] dip point-inside-or-on-halfspace? ;\r
+\r
+: point-inside-face? ( face v -- ? ) \r
+ [ halfspace>> ] dip point-inside-halfspace? ;\r
+\r
+: point-inside-solid? ( solid point -- ? )\r
+ [ faces>> ] dip [ point-inside-face? ] curry all? ; inline\r
+\r
+: point-inside-or-on-solid? ( solid point -- ? )\r
+ [ faces>> ] dip \r
+ [ point-inside-or-on-face? ] curry all? ; inline\r
+\r
+: unvalid-adjacencies ( solid -- solid ) \r
+ erase-old-adjacencies f >>adjacencies-valid \r
+ erase-silhouettes ;\r
+\r
+: add-face ( solid face -- solid ) \r
+ suffix-face unvalid-adjacencies ; \r
+\r
+: cut-solid ( solid halfspace -- solid ) <face> add-face ; \r
+\r
+: slice-solid ( solid face -- solid1 solid2 )\r
+ [ [ clone ] bi@ flip-face add-face \r
+ [ "/outer/" append ] change-name ] 2keep\r
+ add-face [ "/inner/" append ] change-name ;\r
+\r
+! -------------\r
+\r
+\r
+: add-silhouette ( solid -- solid )\r
+ dup \r
+ ! find-adjacencies \r
+ faces>> { } \r
+ [ face-silhouette append ] reduce\r
+ [ ] filter \r
+ <solid> \r
+ swap >>faces\r
+ over dimension>> >>dimension \r
+ over name>> " silhouette " append \r
+ pv> number>string append \r
+ >>name\r
+ ! ensure-adjacencies\r
+ suffix-silhouettes ; inline\r
+\r
+: find-silhouettes ( solid -- solid )\r
+ { } >>silhouettes \r
+ dup dimension>> [ [ add-silhouette ] with-pv ] each ;\r
+\r
+: ensure-silhouettes ( solid -- solid )\r
+ dup silhouettes>> [ f = ] all?\r
+ [ find-silhouettes ] when ; \r
+\r
+! ------------\r
+\r
+: corner-added? ( solid corner -- ? ) \r
+ ! add corner to solid if it is inside solid\r
+ [ ] \r
+ [ point-inside-or-on-solid? ] \r
+ [ swap corners>> member? not ] \r
+ 2tri and\r
+ [ suffix-corner drop t ] [ 2drop f ] if ;\r
+\r
+: process-corner ( solid faces corner -- )\r
+ swapd \r
+ [ corner-added? ] keep swap ! test if corner is inside solid\r
+ [ update-adjacent-faces ] \r
+ [ 2drop ]\r
+ if ;\r
+\r
+: compute-intersection ( solid faces -- )\r
+ dup faces-intersection\r
+ dup f = [ 3drop ] [ process-corner ] if ;\r
+\r
+: test-faces-combinaisons ( solid n -- )\r
+ [ dup faces>> ] dip among \r
+ [ compute-intersection ] with each ;\r
+\r
+: compute-adjacencies ( solid -- solid )\r
+ dup dimension>> [ >= ] curry \r
+ [ keep swap ] curry MAX-FACE-PER-CORNER swap\r
+ [ [ test-faces-combinaisons ] 2keep 1 - ] while drop ;\r
+\r
+: find-adjacencies ( solid -- solid ) \r
+ erase-old-adjacencies \r
+ compute-adjacencies\r
+ filter-real-faces \r
+ t >>adjacencies-valid ;\r
+\r
+: ensure-adjacencies ( solid -- solid ) \r
+ dup adjacencies-valid>> \r
+ [ find-adjacencies ] unless \r
+ ensure-silhouettes\r
+ ;\r
+\r
+: (non-empty-solid?) ( solid -- ? ) \r
+ [ dimension>> ] [ corners>> length ] bi < ;\r
+: non-empty-solid? ( solid -- ? ) \r
+ ensure-adjacencies (non-empty-solid?) ;\r
+\r
+: compare-corners-roughly ( corner corner -- ? )\r
+ 2drop t ;\r
+! : remove-inner-faces ( -- ) ;\r
+: face-project ( array face -- seq )\r
+ backface? \r
+ [ 2drop f ]\r
+ [ [ enlight-projection ] \r
+ [ initiate-solid-from-face ]\r
+ [ intersections-into-faces ] tri\r
+ >>faces\r
+ swap >>color \r
+ ] if ;\r
+\r
+: solid-project ( lights ambient solid -- solids )\r
+ ensure-adjacencies\r
+ [ color>> ] [ faces>> ] bi [ 3array ] dip\r
+ [ face-project ] with map \r
+ [ ] filter \r
+ [ ensure-adjacencies ] map\r
+;\r
+\r
+: (solid-move) ( solid v move -- solid ) \r
+ curry [ map ] curry \r
+ [ dup faces>> ] dip call drop \r
+ unvalid-adjacencies ; inline\r
+\r
+: solid-translate ( solid v -- solid ) \r
+ [ face-translate ] (solid-move) ; \r
+: solid-transform ( solid m -- solid ) \r
+ [ face-transform ] (solid-move) ; \r
+\r
+: find-corner-in-silhouette ( s1 s2 -- elt bool )\r
+ pv> swap silhouettes>> nth \r
+ swap corners>>\r
+ [ point-inside-solid? ] with find swap ;\r
+\r
+: valid-face-for-order ( solid point -- face )\r
+ [ point-inside-face? not ] \r
+ [ drop face-orientation 0 = not ] 2bi and ;\r
+\r
+: check-orientation ( s1 s2 pt -- int )\r
+ [ nip faces>> ] dip\r
+ [ valid-face-for-order ] curry find swap\r
+ [ face-orientation ] [ drop f ] if ;\r
+\r
+: (order-solid) ( s1 s2 -- int )\r
+ 2dup find-corner-in-silhouette\r
+ [ check-orientation ] [ 3drop f ] if ;\r
+\r
+: order-solid ( solid solid -- i ) \r
+ 2dup (order-solid)\r
+ [ 2nip ]\r
+ [ swap (order-solid)\r
+ [ neg ] [ f ] if*\r
+ ] if* ;\r
+\r
+: subtract ( solid1 solid2 -- solids )\r
+ faces>> swap clone ensure-adjacencies ensure-silhouettes \r
+ [ swap slice-solid drop ] curry map\r
+ [ non-empty-solid? ] filter\r
+ [ ensure-adjacencies ] map\r
+; inline\r
+\r
+! -------------------------------------------------------------\r
+! space \r
+! -------------------------------------------------------------\r
+TUPLE: space name dimension solids ambient-color lights ;\r
+: <space> ( -- space ) space new ;\r
+: suffix-solids ( space solid -- space ) \r
+ [ suffix ] curry change-solids ; inline\r
+: suffix-lights ( space light -- space ) \r
+ [ suffix ] curry change-lights ; inline\r
+: clear-space-solids ( space -- space ) f >>solids ;\r
+\r
+: space-ensure-solids ( space -- space ) \r
+ [ [ ensure-adjacencies ] map ] change-solids ;\r
+: eliminate-empty-solids ( space -- space ) \r
+ [ [ non-empty-solid? ] filter ] change-solids ;\r
+\r
+: projected-space ( space solids -- space ) \r
+ swap dimension>> 1 - <space> \r
+ swap >>dimension swap >>solids ;\r
+\r
+: get-silhouette ( solid -- silhouette ) \r
+ silhouettes>> pv> swap nth ;\r
+: solid= ( solid solid -- ? ) [ corners>> ] bi@ = ;\r
+\r
+: space-apply ( space m quot -- space ) \r
+ curry [ map ] curry [ dup solids>> ] dip\r
+ [ call ] [ 2drop ] recover drop ; inline\r
+: space-transform ( space m -- space ) \r
+ [ solid-transform ] space-apply ;\r
+: space-translate ( space v -- space ) \r
+ [ solid-translate ] space-apply ; \r
+\r
+: describe-space ( space -- ) \r
+ solids>> \r
+ [ [ corners>> [ pprint ] each ] [ name>> . ] bi ] each ;\r
+\r
+: clip-solid ( solid solid -- solids )\r
+ [ ]\r
+ [ solid= not ]\r
+ [ order-solid -1 = ] 2tri \r
+ and\r
+ [ get-silhouette subtract ] \r
+ [ drop 1array ] \r
+ if \r
+ \r
+ ;\r
+\r
+: (solids-silhouette-subtract) ( solids solid -- solids ) \r
+ [ clip-solid append ] curry { } -rot each ; inline\r
+\r
+: solids-silhouette-subtract ( solids i solid -- solids )\r
+! solids is an array of 1 solid arrays\r
+ [ (solids-silhouette-subtract) ] curry map-but \r
+; inline \r
+\r
+: remove-hidden-solids ( space -- space ) \r
+! We must include each solid in a sequence because \r
+! during substration \r
+! a solid can be divided in more than on solid\r
+ [ \r
+ [ [ 1array ] map ] \r
+ [ length ] \r
+ [ ] \r
+ tri \r
+ [ solids-silhouette-subtract ] 2each\r
+ { } [ append ] reduce \r
+ ] change-solids\r
+ eliminate-empty-solids ! TODO include into change-solids\r
+;\r
+\r
+: space-project ( space i -- space )\r
+ [\r
+ [ clone \r
+ remove-hidden-solids? [ remove-hidden-solids ] when\r
+ dup \r
+ [ solids>> ] \r
+ [ lights>> ] \r
+ [ ambient-color>> ] tri \r
+ [ rot solid-project ] 2curry \r
+ map \r
+ [ append ] { } -rot each \r
+ ! TODO project lights\r
+ projected-space \r
+ ! remove-inner-faces \r
+ ! \r
+ eliminate-empty-solids\r
+ ] with-pv \r
+ ] [ 3drop <space> ] recover\r
+ ; inline\r
+\r
+: middle-of-space ( space -- point )\r
+ solids>> [ corners>> ] map concat\r
+ [ [ ] [ v+ ] map-reduce ] [ length ] bi v/n\r
+;\r
+\r
+! -------------------------------------------------------------\r
+! 3D rendering\r
+! -------------------------------------------------------------\r
+\r
+: face-reference ( face -- halfspace point vect )\r
+ [ halfspace>> ] \r
+ [ touching-corners>> first ] \r
+ [ touching-corners>> second ] tri \r
+ over v-\r
+;\r
+\r
+: theta ( v halfspace point vect -- v x )\r
+ [ [ over ] dip v- ] dip \r
+ [ cross dup norm >float ]\r
+ [ v. >float ] \r
+ 2bi \r
+ fatan2\r
+ -rot v. \r
+ 0 < [ neg ] when\r
+;\r
+\r
+: ordered-face-points ( face -- corners ) \r
+ [ touching-corners>> 1 head ] \r
+ [ touching-corners>> 1 tail ] \r
+ [ face-reference [ theta ] 3curry ] tri\r
+ { } map>assoc sort-values keys \r
+ append\r
+ ; inline\r
+\r
+: point->GL ( point -- ) gl-vertex ;\r
+: points->GL ( array -- ) do-cycle [ point->GL ] each ;\r
+\r
+: face->GL ( face color -- )\r
+ [ ordered-face-points ] dip\r
+ [ first3 1.0 glColor4d GL_POLYGON \r
+ [ [ point->GL ] each ] do-state ] curry\r
+ [ 0 0 0 1 glColor4d GL_LINE_LOOP \r
+ [ [ point->GL ] each ] do-state ]\r
+ bi\r
+ ; inline\r
+\r
+: solid->GL ( solid -- ) \r
+ [ faces>> ] \r
+ [ color>> ] bi\r
+ [ face->GL ] curry each ; inline\r
+\r
+: space->GL ( space -- )\r
+ solids>>\r
+ [ solid->GL ] each ;\r
+\r
+\r
+\r
+\r
+\r
--- /dev/null
+! : init-4D-demo ( -- space )\r
+! OK\r
+! espace de dimension 4 et de couleur 0,3 0.3 0.3\r
+<space> \r
+ 4 >>dimension\r
+ { 0.3 0.3 0.3 } >>ambient-color\r
+ { 100 150 100 150 100 150 100 150 } "4cube1" 4cube suffix-solids\r
+ { 160 180 160 180 160 180 160 180 } "4cube2" 4cube suffix-solids\r
+ <light>\r
+ { -100 -100 -100 -100 } >>position\r
+ { 0.2 0.7 0.1 } >>color\r
+ suffix-lights\r
+! ;\r
+! : init-3D-demo ( -- space )\r
+! OK\r
+! espace de dimension 4 et de couleur 0,3 0.3 0.3\r
+<space> \r
+ 3 >>dimension\r
+ { 0.3 0.3 0.3 } >>ambient-color\r
+ { 100 150 100 150 100 150 } "3cube1" 3cube suffix-solids\r
+ ! { -150 -10 -150 -10 -150 -10 -150 -10 } "4cube2" 4cube suffix-solids\r
+ <light>\r
+ { -100 -100 -100 -100 } >>position\r
+ { 0.2 0.7 0.1 } >>color\r
+ suffix-lights\r
+! ;\r
+\r
+\r
+: s1 ( -- solid )\r
+ <solid> \r
+ 2 >>dimension\r
+ "s1" >>name\r
+ { 1 1 1 } >>color\r
+ { 1 -1 -5 } cut-solid \r
+ { -1 -1 -21 } cut-solid \r
+ { -1 0 -12 } cut-solid \r
+ { 1 2 16 } cut-solid\r
+;\r
+: solid1 ( -- solid )\r
+ <solid> \r
+ 2 >>dimension\r
+ "solid1" >>name\r
+ { 1 -1 -5 } cut-solid \r
+ { -1 -1 -21 } cut-solid \r
+ { -1 0 -12 } cut-solid \r
+ { 1 2 16 } cut-solid\r
+ ensure-adjacencies\r
+ \r
+;\r
+: solid2 ( -- solid )\r
+ <solid> \r
+ 2 >>dimension\r
+ "solid2" >>name\r
+ { -1 1 -10 } cut-solid \r
+ { -1 -1 -28 } cut-solid \r
+ { 1 0 13 } cut-solid \r
+ ! { 1 2 16 } cut-solid\r
+ ensure-adjacencies\r
+ \r
+;\r
+\r
+: solid3 ( -- solid )\r
+ <solid> \r
+ 2 >>dimension\r
+ "solid3" >>name\r
+ { 1 1 1 } >>color\r
+ { 1 0 16 } cut-solid \r
+ { -1 0 -36 } cut-solid \r
+ { 0 1 1 } cut-solid \r
+ { 0 -1 -17 } cut-solid \r
+ ! { 1 2 16 } cut-solid\r
+ ensure-adjacencies\r
+ \r
+\r
+;\r
+\r
+: solid4 ( -- solid )\r
+ <solid> \r
+ 2 >>dimension\r
+ "solid4" >>name\r
+ { 1 1 1 } >>color\r
+ { 1 0 21 } cut-solid \r
+ { -1 0 -36 } cut-solid \r
+ { 0 1 1 } cut-solid \r
+ { 0 -1 -17 } cut-solid \r
+ ensure-adjacencies\r
+ \r
+;\r
+\r
+: solid5 ( -- solid )\r
+ <solid> \r
+ 2 >>dimension\r
+ "solid5" >>name\r
+ { 1 1 1 } >>color\r
+ { 1 0 6 } cut-solid \r
+ { -1 0 -17 } cut-solid \r
+ { 0 1 17 } cut-solid \r
+ { 0 -1 -19 } cut-solid \r
+ ensure-adjacencies\r
+ \r
+;\r
+\r
+: solid7 ( -- solid )\r
+ <solid> \r
+ 2 >>dimension\r
+ "solid7" >>name\r
+ { 1 1 1 } >>color\r
+ { 1 0 38 } cut-solid \r
+ { 1 -5 -66 } cut-solid \r
+ { -2 1 -75 } cut-solid\r
+ ensure-adjacencies\r
+ \r
+;\r
+\r
+: solid6s ( -- seq )\r
+ solid3 clone solid2 clone subtract\r
+;\r
+\r
+: space1 ( -- space )\r
+ <space>\r
+ 2 >>dimension\r
+ ! solid3 suffix-solids\r
+ solid1 suffix-solids\r
+ solid2 suffix-solids\r
+ ! solid6s [ suffix-solids ] each \r
+ solid4 suffix-solids\r
+ ! solid5 suffix-solids\r
+ solid7 suffix-solids\r
+ { 1 1 1 } >>ambient-color\r
+ <light>\r
+ { -100 -100 } >>position\r
+ { 0.2 0.7 0.1 } >>color\r
+ suffix-lights\r
+;\r
+\r
+: space2 ( -- space )\r
+ <space>\r
+ 4 >>dimension\r
+ ! 4cube suffix-solids\r
+ { 1 1 1 } >>ambient-color\r
+ <light>\r
+ { -100 -100 } >>position\r
+ { 0.2 0.7 0.1 } >>color\r
+ suffix-lights\r
+\r
+ ;\r
+\r
--- /dev/null
+Jeff Bigot\r
+Greg Ferrar
\ No newline at end of file
--- /dev/null
+JF Bigot, after Greg Ferrar
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2008 Jeff Bigot.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays help.markup help.syntax kernel sequences ;
+IN: adsoda.combinators
+
+HELP: among
+{ $values
+ { "array" array } { "n" "number of value to select" }
+ { "array" array }
+}
+{ $description "returns an array containings every possibilities of n choices among a given sequence" } ;
+
+HELP: columnize
+{ $values
+ { "array" array }
+ { "array" array }
+}
+{ $description "flip a sequence into a sequence of 1 element sequences" } ;
+
+HELP: concat-nth
+{ $values
+ { "seq1" sequence } { "seq2" sequence }
+ { "seq" sequence }
+}
+{ $description "merges 2 sequences of sequences appending corresponding elements" } ;
+
+HELP: do-cycle
+{ $values
+ { "array" array }
+ { "array" array }
+}
+{ $description "Copy the first element at the end of the sequence in order to close the cycle." } ;
+
+
+ARTICLE: "adsoda.combinators" "Combinators"
+{ $vocab-link "adsoda.combinators" }
+;
+
+ABOUT: "adsoda.combinators"
--- /dev/null
+USING: adsoda.combinators\r
+sequences\r
+ tools.test \r
+ ;\r
+\r
+IN: adsoda.combinators.tests\r
+\r
+\r
+[ { "atoto" "b" "ctoto" } ] [ { "a" "b" "c" } 1 [ "toto" append ] map-but ] \r
+ unit-test\r
+\r
--- /dev/null
+! Copyright (C) 2008 Jeff Bigot\r
+! See http://factorcode.org/license.txt for BSD license.\r
+USING: kernel arrays sequences fry math combinators ;\r
+\r
+IN: adsoda.combinators\r
+\r
+! : (combinations) ( seq -- seq ) [ 1 tail ] dip combinations ;\r
+\r
+! : prefix-each [ prefix ] curry map ; inline\r
+\r
+! : combinations ( seq n -- seqs )\r
+! {\r
+! { [ dup 0 = ] [ 2drop { { } } ] }\r
+! { [ over empty? ] [ 2drop { } ] }\r
+! { [ t ] [ \r
+! [ [ 1 - (combinations) ] [ drop first ] 2bi prefix-each ]\r
+! [ (combinations) ] 2bi append\r
+! ] }\r
+! } cond ;\r
+\r
+: columnize ( array -- array ) [ 1array ] map ; inline\r
+\r
+: among ( array n -- array )\r
+ 2dup swap length \r
+ {\r
+ { [ over 1 = ] [ 3drop columnize ] }\r
+ { [ over 0 = ] [ 2drop 2drop { } ] }\r
+ { [ 2dup < ] [ 2drop [ 1 cut ] dip \r
+ [ 1 - among [ append ] with map ] \r
+ [ among append ] 2bi\r
+ ] }\r
+ { [ 2dup = ] [ 3drop 1array ] }\r
+ { [ 2dup > ] [ 2drop 2drop { } ] } \r
+ } cond\r
+;\r
+\r
+: concat-nth ( seq1 seq2 -- seq ) \r
+ [ nth append ] curry map-index ;\r
+\r
+: do-cycle ( array -- array ) dup first suffix ;\r
+\r
+: map-but ( seq i quot -- seq )\r
+ ! quot : ( seq x -- seq )\r
+ '[ _ = [ @ ] unless ] map-index ; inline\r
+\r
--- /dev/null
+USING: kernel\r
+sequences\r
+namespaces\r
+\r
+math\r
+math.vectors\r
+math.matrices\r
+;\r
+IN: adsoda.solution2\r
+\r
+! -------------------\r
+! correctif solution\r
+! ---------------\r
+SYMBOL: matrix\r
+: MIN-VAL-adsoda ( -- x ) 0.00000001\r
+! 0.000000000001 \r
+;\r
+\r
+: zero? ( x -- ? ) \r
+ abs MIN-VAL-adsoda <\r
+;\r
+\r
+! [ number>string string>number ] map \r
+\r
+: with-matrix ( matrix quot -- )\r
+ [ swap matrix set call matrix get ] with-scope ; inline\r
+\r
+: nth-row ( row# -- seq ) matrix get nth ;\r
+\r
+: change-row ( row# quot -- seq ) ! row# quot -- | quot: seq -- seq )\r
+ matrix get swap change-nth ; inline\r
+\r
+: exchange-rows ( row# row# -- ) matrix get exchange ;\r
+\r
+: rows ( -- n ) matrix get length ;\r
+\r
+: cols ( -- n ) 0 nth-row length ;\r
+\r
+: skip ( i seq quot -- n )\r
+ over [ find-from drop ] dip length or ; inline\r
+\r
+: first-col ( row# -- n )\r
+ #! First non-zero column\r
+ 0 swap nth-row [ zero? not ] skip ;\r
+\r
+: clear-scale ( col# pivot-row i-row -- n )\r
+ [ over ] dip nth dup zero? [\r
+ 3drop 0\r
+ ] [\r
+ [ nth dup zero? ] dip swap [\r
+ 2drop 0\r
+ ] [\r
+ swap / neg\r
+ ] if\r
+ ] if ;\r
+\r
+: (clear-col) ( col# pivot-row i -- )\r
+ [ [ clear-scale ] 2keep [ n*v ] dip v+ ] change-row ;\r
+\r
+: rows-from ( row# -- slice )\r
+ rows dup <slice> ;\r
+\r
+: clear-col ( col# row# rows -- )\r
+ [ nth-row ] dip [ [ 2dup ] dip (clear-col) ] each 2drop ;\r
+\r
+: do-row ( exchange-with row# -- )\r
+ [ exchange-rows ] keep\r
+ [ first-col ] keep\r
+ dup 1 + rows-from clear-col ;\r
+\r
+: find-row ( row# quot -- i elt )\r
+ [ rows-from ] dip find ; inline\r
+\r
+: pivot-row ( col# row# -- n )\r
+ [ dupd nth-row nth zero? not ] find-row 2nip ;\r
+\r
+: (echelon) ( col# row# -- )\r
+ over cols < over rows < and [\r
+ 2dup pivot-row [ over do-row 1 + ] when*\r
+ [ 1 + ] dip (echelon)\r
+ ] [\r
+ 2drop\r
+ ] if ;\r
+\r
+: echelon ( matrix -- matrix' )\r
+ [ 0 0 (echelon) ] with-matrix ;\r
+\r
+: nonzero-rows ( matrix -- matrix' )\r
+ [ [ zero? ] all? not ] filter ;\r
+\r
+: null/rank ( matrix -- null rank )\r
+ echelon dup length swap nonzero-rows length [ - ] keep ;\r
+\r
+: leading ( seq -- n elt ) [ zero? not ] find ;\r
+\r
+: reduced ( matrix' -- matrix'' )\r
+ [\r
+ rows <reversed> [\r
+ dup nth-row leading drop\r
+ dup [ swap dup clear-col ] [ 2drop ] if\r
+ ] each\r
+ ] with-matrix ;\r
+\r
+: basis-vector ( row col# -- )\r
+ [ clone ] dip\r
+ [ swap nth neg recip ] 2keep\r
+ [ 0 spin set-nth ] 2keep\r
+ [ n*v ] dip\r
+ matrix get set-nth ;\r
+\r
+: nullspace ( matrix -- seq )\r
+ echelon reduced dup empty? [\r
+ dup first length identity-matrix [\r
+ [\r
+ dup leading drop\r
+ dup [ basis-vector ] [ 2drop ] if\r
+ ] each\r
+ ] with-matrix flip nonzero-rows\r
+ ] unless ;\r
+\r
+: 1-pivots ( matrix -- matrix )\r
+ [ dup leading nip [ recip v*n ] when* ] map ;\r
+\r
+: solution ( matrix -- matrix )\r
+ echelon nonzero-rows reduced 1-pivots ;\r
+\r
--- /dev/null
+A modification of solution to approximate solutions
\ No newline at end of file
--- /dev/null
+ADSODA : Arbitrary-Dimensional Solid Object Display Algorithm
\ No newline at end of file
--- /dev/null
+adsoda 4D viewer
\ No newline at end of file
--- /dev/null
+Jeff Bigot
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2008 Jeff Bigot.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays help.markup help.syntax kernel sequences ;
+IN: adsoda.tools
+
+HELP: 3cube
+{ $values
+ { "array" "array" } { "name" "name" }
+ { "solid" "solid" }
+}
+{ $description "array : xmin xmax ymin ymax zmin zmax"
+"returns a 3D solid with given limits"
+} ;
+
+HELP: 4cube
+{ $values
+ { "array" "array" } { "name" "name" }
+ { "solid" "solid" }
+}
+{ $description "array : xmin xmax ymin ymax zmin zmax wmin wmax"
+"returns a 4D solid with given limits"
+} ;
+
+
+HELP: equation-system-for-normal
+{ $values
+ { "points" "a list of n points" }
+ { "matrix" "matrix" }
+}
+{ $description "From a list of points, return the matrix"
+"to solve in order to find the vector normal to the plan defined by the points" }
+;
+
+HELP: normal-vector
+{ $values
+ { "points" "a list of n points" }
+ { "v" "a vector" }
+}
+{ $description "From a list of points, returns the vector normal to the plan defined by the points"
+"With n points, creates n-1 vectors and then find a vector orthogonal to every others"
+"returns { f } if a normal vector can not be found" }
+;
+
+HELP: points-to-hyperplane
+{ $values
+ { "points" "a list of n points" }
+ { "hyperplane" "an hyperplane equation" }
+}
+{ $description "From a list of points, returns the equation of the hyperplan"
+"Finds a normal vector and then translate it so that it includes one of the points"
+
+}
+;
+
+ARTICLE: "adsoda.tools" "Tools"
+{ $vocab-link "adsoda.tools" }
+"Tools to help in building an " { $vocab-link "adsoda" } "-space"
+;
+
+ABOUT: "adsoda.tools"
+
+
--- /dev/null
+! Copyright (C) 2008 Jeff Bigot\r
+! See http://factorcode.org/license.txt for BSD license.\r
+USING: \r
+adsoda.tools\r
+tools.test\r
+;\r
+\r
+IN: adsoda.tools.tests\r
+\r
+\r
+ [ { 1 0 } ] [ { { 0 0 } { 0 1 } } normal-vector ] unit-test\r
+ [ f ] [ { { 0 0 } { 0 0 } } normal-vector ] unit-test\r
+\r
+ [ { 1/2 1/2 1+1/2 } ] [ { { 1 2 } { 2 1 } } points-to-hyperplane ] unit-test\r
--- /dev/null
+! Copyright (C) 2008 Jeff Bigot\r
+! See http://factorcode.org/license.txt for BSD license.\r
+USING: \r
+kernel\r
+sequences\r
+math\r
+accessors\r
+adsoda\r
+math.vectors \r
+math.matrices\r
+bunny.model\r
+io.encodings.ascii\r
+io.files\r
+sequences.deep\r
+combinators\r
+adsoda.combinators\r
+fry\r
+io.files.temp\r
+grouping\r
+;\r
+\r
+IN: adsoda.tools\r
+\r
+\r
+\r
+\r
+\r
+! ---------------------------------\r
+: coord-min ( x array -- array ) swap suffix ;\r
+: coord-max ( x array -- array ) swap neg suffix ;\r
+\r
+: 4cube ( array name -- solid )\r
+! array : xmin xmax ymin ymax zmin zmax wmin wmax\r
+ <solid> \r
+ 4 >>dimension\r
+ swap >>name\r
+ swap\r
+ { \r
+ [ { 1 0 0 0 } coord-min ] [ { -1 0 0 0 } coord-max ] \r
+ [ { 0 1 0 0 } coord-min ] [ { 0 -1 0 0 } coord-max ]\r
+ [ { 0 0 1 0 } coord-min ] [ { 0 0 -1 0 } coord-max ] \r
+ [ { 0 0 0 1 } coord-min ] [ { 0 0 0 -1 } coord-max ]\r
+ }\r
+ [ curry call ] 2map \r
+ [ cut-solid ] each \r
+ ensure-adjacencies\r
+ \r
+; inline\r
+\r
+: 3cube ( array name -- solid )\r
+! array : xmin xmax ymin ymax zmin zmax wmin wmax\r
+ <solid> \r
+ 3 >>dimension\r
+ swap >>name\r
+ swap\r
+ { \r
+ [ { 1 0 0 } coord-min ] [ { -1 0 0 } coord-max ] \r
+ [ { 0 1 0 } coord-min ] [ { 0 -1 0 } coord-max ]\r
+ [ { 0 0 1 } coord-min ] [ { 0 0 -1 } coord-max ] \r
+ }\r
+ [ curry call ] 2map \r
+ [ cut-solid ] each \r
+ ensure-adjacencies\r
+ \r
+; inline\r
+\r
+\r
+: equation-system-for-normal ( points -- matrix )\r
+ unclip [ v- 0 suffix ] curry map\r
+ dup first [ drop 1 ] map suffix\r
+;\r
+\r
+: normal-vector ( points -- v ) \r
+ equation-system-for-normal\r
+ intersect-hyperplanes ;\r
+\r
+: points-to-hyperplane ( points -- hyperplane )\r
+ [ normal-vector 0 suffix ] [ first ] bi\r
+ translate ;\r
+\r
+: refs-to-points ( points faces -- faces )\r
+ [ swap [ nth 10 v*n { 100 100 100 } v+ ] curry map ] \r
+ with map\r
+;\r
+! V{ { 0.1 0.2 } { 1.1 1.3 } } V{ { 1 0 } { 0 1 } }\r
+! V{ { { 1.1 1.3 } { 0.1 0.2 } } { { 0.1 0.2 } { 1.1 1.3 } } }\r
+\r
+: ply-model-path ( -- path )\r
+\r
+! "bun_zipper.ply" \r
+"screw2.ply"\r
+temp-file \r
+;\r
+\r
+: read-bunny-model ( -- v )\r
+ply-model-path ascii [ parse-model ] with-file-reader\r
+\r
+refs-to-points\r
+;\r
+\r
+: 3points-to-normal ( seq -- v )\r
+ unclip [ v- ] curry map first2 cross normalize\r
+;\r
+: 2-faces-to-prism ( seq seq -- seq )\r
+ 2dup\r
+ [ do-cycle 2 clump ] bi@ concat-nth \r
+ ! 3 faces rectangulaires\r
+ swap prefix\r
+ swap prefix\r
+; \r
+\r
+: Xpoints-to-prisme ( seq height -- cube )\r
+ ! from 3 points gives a list of faces representing \r
+ ! a cube of height "height"\r
+ ! and of based on the three points\r
+ ! a face is a group of 3 or mode points. \r
+ [ dup dup 3points-to-normal ] dip \r
+ v*n [ v+ ] curry map ! 2 eme face triangulaire \r
+ 2-faces-to-prism \r
+\r
+! [ dup number? [ 1 + ] when ] deep-map\r
+! dup keep \r
+;\r
+\r
+\r
+: Xpoints-to-plane4D ( seq x y -- 4Dplane )\r
+ ! from 3 points gives a list of faces representing \r
+ ! a cube in 4th dim\r
+ ! from x to y (height = y-x)\r
+ ! and of based on the X points\r
+ ! a face is a group of 3 or mode points. \r
+ '[ [ [ _ suffix ] map ] [ [ _ suffix ] map ] bi ] call\r
+ 2-faces-to-prism\r
+;\r
+\r
+: 3pointsfaces-to-3Dsolidfaces ( seq -- seq )\r
+ [ 1 Xpoints-to-prisme [ 100 \r
+ 110 Xpoints-to-plane4D ] map concat ] map \r
+\r
+;\r
+\r
+: test-figure ( -- solid )\r
+ <solid> \r
+ 2 >>dimension\r
+ { 1 -1 -5 } cut-solid \r
+ { -1 -1 -21 } cut-solid \r
+ { -1 0 -12 } cut-solid \r
+ { 1 2 16 } cut-solid\r
+;\r
+\r
projects / factor.git / commitdiff