diff --git a/basis/bit-arrays/bit-arrays-tests.factor b/basis/bit-arrays/bit-arrays-tests.factor index a5ae23dde6..24c27fa15b 100644 --- a/basis/bit-arrays/bit-arrays-tests.factor +++ b/basis/bit-arrays/bit-arrays-tests.factor @@ -76,3 +76,5 @@ IN: bit-arrays.tests t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t } bit-array>integer ] unit-test + +[ 49 ] [ 49 dup set-bits [ ] count ] unit-test diff --git a/basis/bit-arrays/bit-arrays.factor b/basis/bit-arrays/bit-arrays.factor index 66c786f6bb..18796fbfed 100644 --- a/basis/bit-arrays/bit-arrays.factor +++ b/basis/bit-arrays/bit-arrays.factor @@ -25,7 +25,7 @@ TUPLE: bit-array : (set-bits) ( bit-array n -- ) [ [ length bits>cells ] keep ] dip swap underlying>> - '[ [ _ _ ] dip set-alien-unsigned-4 ] each ; inline + '[ 2 shift [ _ _ ] dip set-alien-unsigned-4 ] each ; inline PRIVATE> diff --git a/basis/help/help-docs.factor b/basis/help/help-docs.factor index 4a06235c69..a699747048 100644 --- a/basis/help/help-docs.factor +++ b/basis/help/help-docs.factor @@ -327,7 +327,7 @@ HELP: $table HELP: $values { $values { "element" "an array of pairs of markup elements" } } -{ $description "Prints the description of arguments and values found on every word help page. The first element of a pair is the argument name and is output with " { $link $snippet } ". The remainder is either a single class word, or an element. If it is a class word " { $snippet "class" } ", it is intereted as if it were shorthand for " { $snippet "{ $instance class }" } "." } +{ $description "Prints the description of arguments and values found on every word help page. The first element of a pair is the argument name and is output with " { $link $snippet } ". The remainder is either a single class word, or an element. If it is a class word " { $snippet "class" } ", it is inserted as if it were shorthand for " { $snippet "{ $instance class }" } "." } { $see-also $maybe $instance $quotation } ; HELP: $instance diff --git a/basis/math/miller-rabin/miller-rabin.factor b/basis/math/miller-rabin/miller-rabin.factor index afaa66e68f..374616ba40 100755 --- a/basis/math/miller-rabin/miller-rabin.factor +++ b/basis/math/miller-rabin/miller-rabin.factor @@ -4,9 +4,9 @@ USING: combinators io locals kernel math math.functions math.ranges namespaces random sequences hashtables sets ; IN: math.miller-rabin -: >even ( n -- int ) dup even? [ 1- ] unless ; foldable +odd ( n -- int ) dup even? [ 1+ ] when ; foldable -: next-odd ( m -- n ) dup even? [ 1+ ] [ 2 + ] if ; TUPLE: positive-even-expected n ; @@ -28,6 +28,10 @@ TUPLE: positive-even-expected n ; ] unless drop ] each prime? ] ; +PRIVATE> + +: next-odd ( m -- n ) dup even? [ 1+ ] [ 2 + ] if ; + : miller-rabin* ( n numtrials -- ? ) over { { [ dup 1 <= ] [ 3drop f ] } @@ -46,11 +50,15 @@ TUPLE: positive-even-expected n ; ERROR: no-relative-prime n ; + [ 2 + (find-relative-prime) ] [ nip ] if ; +PRIVATE> + : find-relative-prime* ( n guess -- p ) #! find a prime relative to n with initial guess >odd (find-relative-prime) ; diff --git a/extra/4DNav/4DNav-docs.factor b/extra/4DNav/4DNav-docs.factor new file mode 100755 index 0000000000..d4bf1db87d --- /dev/null +++ b/extra/4DNav/4DNav-docs.factor @@ -0,0 +1,400 @@ +! Copyright (C) 2008 Jean-François Bigot. +! See http://factorcode.org/license.txt for BSD license. +USING: help.markup help.syntax kernel quotations strings ; +IN: 4DNav + +HELP: (mvt-4D) +{ $values + { "quot" quotation } +} +{ $description "" } ; + +HELP: 4D-Rxw +{ $values + { "angle" null } + { "Rz" null } +} +{ $description "" } ; + +HELP: 4D-Rxy +{ $values + { "angle" null } + { "Rx" null } +} +{ $description "" } ; + +HELP: 4D-Rxz +{ $values + { "angle" null } + { "Ry" null } +} +{ $description "" } ; + +HELP: 4D-Ryw +{ $values + { "angle" null } + { "Ry" null } +} +{ $description "" } ; + +HELP: 4D-Ryz +{ $values + { "angle" null } + { "Rx" null } +} +{ $description "" } ; + +HELP: 4D-Rzw +{ $values + { "angle" null } + { "Rz" null } +} +{ $description "" } ; + +HELP: 4DNav +{ $description "" } ; + +HELP: >observer3d +{ $values + { "value" null } +} +{ $description "" } ; + +HELP: >present-space +{ $values + { "value" null } +} +{ $description "" } ; + + +HELP: >view1 +{ $values + { "value" null } +} +{ $description "" } ; + +HELP: >view2 +{ $values + { "value" null } +} +{ $description "" } ; + +HELP: >view3 +{ $values + { "value" null } +} +{ $description "" } ; + +HELP: >view4 +{ $values + { "value" null } +} +{ $description "" } ; + +HELP: add-keyboard-delegate +{ $values + { "obj" object } + { "obj" object } +} +{ $description "" } ; + +HELP: button* +{ $values + { "string" string } { "quot" quotation } + { "button" null } +} +{ $description "" } ; + +HELP: camera-action +{ $values + { "quot" quotation } + { "quot" quotation } +} +{ $description "" } ; + +HELP: camera-button +{ $values + { "string" string } { "quot" quotation } + { "button" null } +} +{ $description "" } ; + +HELP: controller-window* +{ $values + { "gadget" "a gadget" } +} +{ $description "" } ; + + +HELP: init-models +{ $description "" } ; + +HELP: init-variables +{ $description "" } ; + +HELP: menu-3D +{ $values + { "gadget" null } +} +{ $description "The menu dedicated to 3D movements of the camera" } ; + +HELP: menu-4D +{ $values + + { "gadget" null } +} +{ $description "The menu dedicated to 4D movements of space" } ; + +HELP: menu-bar +{ $values + + { "gadget" null } +} +{ $description "return gadget containing menu buttons" } ; + +HELP: model-projection +{ $values + { "x" null } + { "space" null } +} +{ $description "Project space following coordinate x" } ; + +HELP: mvt-3D-1 +{ $values + + { "quot" quotation } +} +{ $description "return a quotation to orientate space to see it from first point of view" } ; + +HELP: mvt-3D-2 +{ $values + + { "quot" quotation } +} +{ $description "return a quotation to orientate space to see it from second point of view" } ; + +HELP: mvt-3D-3 +{ $values + + { "quot" quotation } +} +{ $description "return a quotation to orientate space to see it from third point of view" } ; + +HELP: mvt-3D-4 +{ $values + + { "quot" quotation } +} +{ $description "return a quotation to orientate space to see it from first point of view" } ; + +HELP: observer3d +{ $description "" } ; + +HELP: observer3d> +{ $values + + { "value" null } +} +{ $description "" } ; + +HELP: present-space +{ $description "" } ; + +HELP: present-space> +{ $values + + { "value" null } +} +{ $description "" } ; + +HELP: load-model-file +{ $description "load space from file" } ; + +HELP: rotation-4D +{ $values + { "m" "a rotation matrix" } +} +{ $description "Apply a 4D rotation matrix" } ; + +HELP: translation-4D +{ $values + { "v" null } +} +{ $description "" } ; + +HELP: update-model-projections +{ $description "" } ; + +HELP: update-observer-projections +{ $description "" } ; + +HELP: view1 +{ $description "" } ; + +HELP: view1> +{ $values + + { "value" null } +} +{ $description "" } ; + +HELP: view2 +{ $description "" } ; + +HELP: view2> +{ $values + + { "value" null } +} +{ $description "" } ; + +HELP: view3 +{ $description "" } ; + +HELP: view3> +{ $values + + { "value" null } +} +{ $description "" } ; + +HELP: view4 +{ $description "" } ; + +HELP: view4> +{ $values + + { "value" null } +} +{ $description "" } ; + +HELP: viewer-windows* +{ $description "" } ; + +HELP: win3D +{ $values + { "text" null } { "gadget" null } +} +{ $description "" } ; + +HELP: windows +{ $description "" } ; + +ARTICLE: "Space file" "Create a new space file" +"\nTo build a new space, create an XML file using " { $vocab-link "adsoda" } " model description. \nAn example is:" +$nl + +"\n" +"\n" +"\n 4" +"\n " +"\n 4cube1" +"\n 4" +"\n 1,0,0,0,100" +"\n -1,0,0,0,-150" +"\n 0,1,0,0,100" +"\n 0,-1,0,0,-150" +"\n 0,0,1,0,100" +"\n 0,0,-1,0,-150" +"\n 0,0,0,1,100" +"\n 0,0,0,-1,-150" +"\n 1,0,0" +"\n " +"\n " +"\n 4triancube" +"\n 4" +"\n 1,0,0,0,160" +"\n -0.4999999999999998,-0.8660254037844387,0,0,-130" +"\n -0.5000000000000004,0.8660254037844384,0,0,-130" +"\n 0,0,1,0,140" +"\n 0,0,-1,0,-180" +"\n 0,0,0,1,110" +"\n 0,0,0,-1,-180" +"\n 0,1,0" +"\n " +"\n " +"\n triangone" +"\n 4" +"\n 1,0,0,0,60" +"\n 0.5,0.8660254037844386,0,0,60" +"\n -0.5,0.8660254037844387,0,0,-20" +"\n -1.0,0,0,0,-100" +"\n -0.5,-0.8660254037844384,0,0,-100" +"\n 0.5,-0.8660254037844387,0,0,-20" +"\n 0,0,1,0,120" +"\n 0,0,-0.4999999999999998,-0.8660254037844387,-120" +"\n 0,0,-0.5000000000000004,0.8660254037844384,-120" +"\n 0,1,1" +"\n " +"\n " +"\n 1,1,1,1" +"\n 0.2,0.2,0.6" +"\n " +"\n 0.8,0.9,0.9" +"\n" +"\n" + + +; + +ARTICLE: "TODO" "Todo" +{ $list + "A file chooser" + "A vocab to initialize parameters" + "an editor mode" + { $list "add a face to a solid" + "add a solid to the space" + "move a face" + "move a solid" + "select a solid in a list" + "select a face" + "display selected face" + "edit a solid color" + "add a light" + "edit a light color" + "move a light" + } + "add a tool wich give an hyperplane normal vector with enought points. Will use adsoda.intersect-hyperplanes with { { 0 } { 0 } { 1 } } " + "decorrelate 3D camera and activate them with select buttons" + + + +} ; + + +ARTICLE: "4DNav" "4DNav" +{ $vocab-link "4DNav" } +$nl +{ $heading "4D Navigator" } +"4DNav is a simple tool to visualize 4 dimensionnal objects." +"\n" +"It uses " { $vocab-link "adsoda" } " library to display a 4D space and navigate thru it." + +"It will display:" +{ $list + { "a menu window" } + { "4 visualization windows" } +} +"Each window represents the projection of the 4D space on a particular 3D space." +$nl + +{ $heading "Initialization" } +"put the space file " { $strong "space-exemple.xml" } " in temp directory" +" and then type:" { $code "\"4DNav\" run" } +{ $heading "Navigation" } +"4D submenu move the space in translations and rotation." +"\n3D submenu move the camera in 3D space. Cameras in every 3D spaces are manipulated as a single one" +$nl + + + + +{ $heading "Links" } +{ $subsection "Space file" } + +{ $subsection "TODO" } + + +; + +ABOUT: "4DNav" diff --git a/extra/4DNav/4DNav.factor b/extra/4DNav/4DNav.factor new file mode 100755 index 0000000000..3a0543df1a --- /dev/null +++ b/extra/4DNav/4DNav.factor @@ -0,0 +1,524 @@ +! Copyright (C) 2008 Jeff Bigot +! See http://factorcode.org/license.txt for BSD license. +USING: kernel +namespaces +accessors +make +math +math.functions +math.trig +math.parser +hashtables +sequences +combinators +continuations +colors +prettyprint +vars +quotations +io +io.directories +io.pathnames +help.markup +io.files +ui.gadgets.panes + ui + ui.gadgets + ui.traverse + ui.gadgets.borders + ui.gadgets.handler + ui.gadgets.slate + ui.gadgets.theme + ui.gadgets.frames + ui.gadgets.tracks + ui.gadgets.labels + ui.gadgets.labelled + ui.gadgets.lists + ui.gadgets.buttons + ui.gadgets.packs + ui.gadgets.grids + ui.gestures + ui.tools.workspace + ui.gadgets.scrollers +splitting +vectors +math.vectors +rewrite-closures +self +values +4DNav.turtle +4DNav.window3D +4DNav.deep +4DNav.space-file-decoder +models +fry +adsoda +adsoda.tools +; + +IN: 4DNav +VALUE: selected-file +VALUE: translation-step +VALUE: rotation-step + +3 to: translation-step +5 to: rotation-step + +VAR: selected-file-model +VAR: observer3d +VAR: view1 +VAR: view2 +VAR: view3 +VAR: view4 +VAR: present-space + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +! replacement of namespaces.lib + +: make* ( seq -- seq ) [ dup quotation? [ call ] [ ] if ] map ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! waiting for deep-cleave-quots + +: 4D-Rxy ( angle -- Rx ) deg>rad +[ 1.0 , 0.0 , 0.0 , 0.0 , + 0.0 , 1.0 , 0.0 , 0.0 , + 0.0 , 0.0 , dup cos , dup sin neg , + 0.0 , 0.0 , dup sin , dup cos , ] 4 make-matrix nip ; + +: 4D-Rxz ( angle -- Ry ) deg>rad +[ 1.0 , 0.0 , 0.0 , 0.0 , + 0.0 , dup cos , 0.0 , dup sin neg , + 0.0 , 0.0 , 1.0 , 0.0 , + 0.0 , dup sin , 0.0 , dup cos , ] 4 make-matrix nip ; + +: 4D-Rxw ( angle -- Rz ) deg>rad +[ 1.0 , 0.0 , 0.0 , 0.0 , + 0.0 , dup cos , dup sin neg , 0.0 , + 0.0 , dup sin , dup cos , 0.0 , + 0.0 , 0.0 , 0.0 , 1.0 , ] 4 make-matrix nip ; + +: 4D-Ryz ( angle -- Rx ) deg>rad +[ dup cos , 0.0 , 0.0 , dup sin neg , + 0.0 , 1.0 , 0.0 , 0.0 , + 0.0 , 0.0 , 1.0 , 0.0 , + dup sin , 0.0 , 0.0 , dup cos , ] 4 make-matrix nip ; + +: 4D-Ryw ( angle -- Ry ) deg>rad +[ dup cos , 0.0 , dup sin neg , 0.0 , + 0.0 , 1.0 , 0.0 , 0.0 , + dup sin , 0.0 , dup cos , 0.0 , + 0.0 , 0.0 , 0.0 , 1.0 , ] 4 make-matrix nip ; + +: 4D-Rzw ( angle -- Rz ) deg>rad +[ dup cos , dup sin neg , 0.0 , 0.0 , + dup sin , dup cos , 0.0 , 0.0 , + 0.0 , 0.0 , 1.0 , 0.0 , + 0.0 , 0.0 , 0.0 , 1.0 , ] 4 make-matrix nip ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! UI +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: button* ( string quot -- button ) closed-quot ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: model-projection-chooser ( -- gadget ) + observer3d> projection-mode>> + { { 1 "perspective" } { 0 "orthogonal" } } ; + +: collision-detection-chooser ( -- gadget ) + observer3d> collision-mode>> + { { t "on" } { f "off" } } +; + +: model-projection ( x -- space ) present-space> swap space-project ; + +: update-observer-projections ( -- ) + view1> relayout-1 + view2> relayout-1 + view3> relayout-1 + view4> relayout-1 ; + +: update-model-projections ( -- ) + 0 model-projection view1> (>>model) + 1 model-projection view2> (>>model) + 2 model-projection view3> (>>model) + 3 model-projection view4> (>>model) ; + +: camera-action ( quot -- quot ) + [ drop [ ] observer3d> with-self update-observer-projections ] + make* closed-quot ; + +: win3D ( text gadget -- ) "navigateur 4D : " rot append open-window ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! 4D object manipulation +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: (mvt-4D) ( quot -- ) + present-space> + swap call space-ensure-solids + >present-space + update-model-projections + update-observer-projections ; + +: rotation-4D ( m -- ) + '[ _ [ [ middle-of-space dup vneg ] keep swap space-translate ] dip + space-transform + swap space-translate + ] (mvt-4D) ; + +: translation-4D ( v -- ) '[ _ space-translate ] (mvt-4D) ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! menu +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: menu-rotations-4D ( -- gadget ) + + 1 >>fill + "XY +" [ drop rotation-step 4D-Rxy rotation-4D ] button* add-gadget + "XY -" [ drop rotation-step neg 4D-Rxy rotation-4D ] button* add-gadget + @top-left grid-add + 1 >>fill + "XZ +" [ drop rotation-step 4D-Rxz rotation-4D ] button* add-gadget + "XZ -" [ drop rotation-step neg 4D-Rxz rotation-4D ] button* add-gadget + @top grid-add + 1 >>fill + "YZ +" [ drop rotation-step 4D-Ryz rotation-4D ] button* add-gadget + "YZ -" [ drop rotation-step neg 4D-Ryz rotation-4D ] button* add-gadget + @center grid-add + 1 >>fill + "XW +" [ drop rotation-step 4D-Rxw rotation-4D ] button* add-gadget + "XW -" [ drop rotation-step neg 4D-Rxw rotation-4D ] button* add-gadget + @top-right grid-add + 1 >>fill + "YW +" [ drop rotation-step 4D-Ryw rotation-4D ] button* add-gadget + "YW -" [ drop rotation-step neg 4D-Ryw rotation-4D ] button* add-gadget + @right grid-add + 1 >>fill + "ZW +" [ drop rotation-step 4D-Rzw rotation-4D ] button* add-gadget + "ZW -" [ drop rotation-step neg 4D-Rzw rotation-4D ] button* add-gadget + @bottom-right grid-add +; + +: menu-translations-4D ( -- gadget ) + + 1 >>fill + 1 >>fill + "X+" [ drop { 1 0 0 0 } translation-step v*n translation-4D ] + button* add-gadget + "X-" [ drop { -1 0 0 0 } translation-step v*n translation-4D ] + button* add-gadget + add-gadget + "YZW"