From 70573c01f07b1aecd9abe14fd44b0cd87f00a141 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 6 Apr 2008 14:33:01 -0500 Subject: [PATCH 01/15] comment out compiler error --- extra/db/mysql/lib/lib.factor | 20 ++++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/extra/db/mysql/lib/lib.factor b/extra/db/mysql/lib/lib.factor index 59d1b6ff3d..ca912f200d 100644 --- a/extra/db/mysql/lib/lib.factor +++ b/extra/db/mysql/lib/lib.factor @@ -18,16 +18,16 @@ TUPLE: mysql-result-set ; : mysql-error ( mysql -- ) [ mysql_error throw ] when* ; -: mysql-connect ( mysql-connection -- ) - new-mysql over set-mysql-db-handle - dup { - mysql-db-handle - mysql-db-host - mysql-db-user - mysql-db-password - mysql-db-db - mysql-db-port - } get-slots f 0 mysql_real_connect mysql-error ; +! : mysql-connect ( mysql-connection -- ) + ! new-mysql over set-mysql-db-handle + ! dup { + ! mysql-db-handle + ! mysql-db-host + ! mysql-db-user + ! mysql-db-password + ! mysql-db-db + ! mysql-db-port + ! } get-slots f 0 mysql_real_connect mysql-error ; ! ========================================================= ! Low level mysql utility definitions From ddb1749c57743c25d7667c9484fa854ee98abf50 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 6 Apr 2008 21:07:21 -0500 Subject: [PATCH 02/15] ERROR: should be inside the IN: --- extra/opengl/gl/extensions/extensions.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/opengl/gl/extensions/extensions.factor b/extra/opengl/gl/extensions/extensions.factor index b8ac396c2f..20929fb410 100644 --- a/extra/opengl/gl/extensions/extensions.factor +++ b/extra/opengl/gl/extensions/extensions.factor @@ -1,6 +1,7 @@ USING: alien alien.syntax combinators kernel parser sequences system words namespaces hashtables init math arrays assocs continuations ; +IN: opengl.gl.extensions ERROR: unknown-gl-platform ; << { @@ -9,7 +10,6 @@ ERROR: unknown-gl-platform ; { [ os unix? ] [ "opengl.gl.unix" ] } { [ t ] [ unknown-gl-platform ] } } cond use+ >> -IN: opengl.gl.extensions SYMBOL: +gl-function-number-counter+ SYMBOL: +gl-function-pointers+ From b1b889d8994e96968a47c5f93642fc76b6eb9864 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 7 Apr 2008 15:30:06 -0500 Subject: [PATCH 03/15] add some acl constants --- extra/windows/advapi32/advapi32.factor | 195 ++++++++++++++++--------- 1 file changed, 129 insertions(+), 66 deletions(-) diff --git a/extra/windows/advapi32/advapi32.factor b/extra/windows/advapi32/advapi32.factor index 28091d3d9d..0d2f164c8d 100644 --- a/extra/windows/advapi32/advapi32.factor +++ b/extra/windows/advapi32/advapi32.factor @@ -61,6 +61,133 @@ LIBRARY: advapi32 : CRYPT_MACHINE_KEYSET HEX: 20 ; inline : CRYPT_SILENT HEX: 40 ; inline +C-STRUCT: ACL + { "BYTE" "AclRevision" } + { "BYTE" "Sbz1" } + { "WORD" "AclSize" } + { "WORD" "AceCount" } + { "WORD" "Sbz2" } ; + +TYPEDEF: ACL* PACL + +: ACCESS_ALLOWED_ACE_TYPE 0 ; inline +: ACCESS_DENIED_ACE_TYPE 1 ; inline +: SYSTEM_AUDIT_ACE_TYPE 2 ; inline +: SYSTEM_ALARM_ACE_TYPE 3 ; inline + +: OBJECT_INHERIT_ACE HEX: 1 ; inline +: CONTAINER_INHERIT_ACE HEX: 2 ; inline +: NO_PROPAGATE_INHERIT_ACE HEX: 4 ; inline +: INHERIT_ONLY_ACE HEX: 8 ; inline +: VALID_INHERIT_FLAGS HEX: f ; inline + +C-STRUCT: ACE_HEADER + { "BYTE" "AceType" } + { "BYTE" "AceFlags" } + { "WORD" "AceSize" } ; + +TYPEDEF: ACE_HEADER* PACE_HEADER + +C-STRUCT: ACCESS_ALLOWED_ACE + { "ACE_HEADER" "Header" } + { "DWORD" "Mask" } + { "DWORD" "SidStart" } ; + +TYPEDEF: ACCESS_ALLOWED_ACE* PACCESS_ALLOWED_ACE + +C-STRUCT: ACCESS_DENIED_ACE + { "ACE_HEADER" "Header" } + { "DWORD" "Mask" } + { "DWORD" "SidStart" } ; +TYPEDEF: ACCESS_DENIED_ACE* PACCESS_DENIED_ACE + + +C-STRUCT: SYSTEM_AUDIT_ACE + { "ACE_HEADER" "Header" } + { "DWORD" "Mask" } + { "DWORD" "SidStart" } ; + +TYPEDEF: SYSTEM_AUDIT_ACE* PSYSTEM_AUDIT_ACE + +C-STRUCT: SYSTEM_ALARM_ACE + { "ACE_HEADER" "Header" } + { "DWORD" "Mask" } + { "DWORD" "SidStart" } ; + +TYPEDEF: SYSTEM_ALARM_ACE* PSYSTEM_ALARM_ACE + +C-STRUCT: ACCESS_ALLOWED_CALLBACK_ACE + { "ACE_HEADER" "Header" } + { "DWORD" "Mask" } + { "DWORD" "SidStart" } ; + +TYPEDEF: ACCESS_ALLOWED_CALLBACK_ACE* PACCESS_ALLOWED_CALLBACK_ACE + + +! typedef enum _TOKEN_INFORMATION_CLASS { +: TokenUser 1 ; inline +: TokenGroups 2 ; inline +: TokenPrivileges 3 ; inline +: TokenOwner 4 ; inline +: TokenPrimaryGroup 5 ; inline +: TokenDefaultDacl 6 ; inline +: TokenSource 7 ; inline +: TokenType 8 ; inline +: TokenImpersonationLevel 9 ; inline +: TokenStatistics 10 ; inline +: TokenRestrictedSids 11 ; inline +: TokenSessionId 12 ; inline +: TokenGroupsAndPrivileges 13 ; inline +: TokenSessionReference 14 ; inline +: TokenSandBoxInert 15 ; inline +! } TOKEN_INFORMATION_CLASS; + +: DELETE HEX: 00010000 ; inline +: READ_CONTROL HEX: 00020000 ; inline +: WRITE_DAC HEX: 00040000 ; inline +: WRITE_OWNER HEX: 00080000 ; inline +: SYNCHRONIZE HEX: 00100000 ; inline +: STANDARD_RIGHTS_REQUIRED HEX: 000f0000 ; inline + +: STANDARD_RIGHTS_READ READ_CONTROL ; inline +: STANDARD_RIGHTS_WRITE READ_CONTROL ; inline +: STANDARD_RIGHTS_EXECUTE READ_CONTROL ; inline + +: TOKEN_TOKEN_ADJUST_DEFAULT HEX: 0080 ; inline +: TOKEN_ADJUST_GROUPS HEX: 0040 ; inline +: TOKEN_ADJUST_PRIVILEGES HEX: 0020 ; inline +: TOKEN_ADJUST_SESSIONID HEX: 0100 ; inline +: TOKEN_ASSIGN_PRIMARY HEX: 0001 ; inline +: TOKEN_DUPLICATE HEX: 0002 ; inline +: TOKEN_EXECUTE STANDARD_RIGHTS_EXECUTE ; inline +: TOKEN_IMPERSONATE HEX: 0004 ; inline +: TOKEN_QUERY HEX: 0008 ; inline +: TOKEN_QUERY_SOURCE HEX: 0010 ; inline +: TOKEN_ADJUST_DEFAULT HEX: 0080 ; inline +: TOKEN_READ STANDARD_RIGHTS_READ TOKEN_QUERY bitor ; + +: TOKEN_WRITE + { + STANDARD_RIGHTS_WRITE + TOKEN_ADJUST_PRIVILEGES + TOKEN_ADJUST_GROUPS + TOKEN_ADJUST_DEFAULT + } flags ; foldable + +: TOKEN_ALL_ACCESS + { + STANDARD_RIGHTS_REQUIRED + TOKEN_ASSIGN_PRIMARY + TOKEN_DUPLICATE + TOKEN_IMPERSONATE + TOKEN_QUERY + TOKEN_QUERY_SOURCE + TOKEN_ADJUST_PRIVILEGES + TOKEN_ADJUST_GROUPS + TOKEN_ADJUST_SESSIONID + TOKEN_ADJUST_DEFAULT + } flags ; foldable + ! : I_ScGetCurrentGroupStateW ; ! : A_SHAFinal ; @@ -85,7 +212,7 @@ LIBRARY: advapi32 ! : AddAccessDeniedAce ; ! : AddAccessDeniedAceEx ; ! : AddAccessDeniedObjectAce ; -! : AddAce ; +FUNCTION: BOOL AddAce ( PACL pAcl, DWORD dwAceRevision, DWORD dwStartingAceIndex, LPVOID pAceList, DWORD nAceListLength ) ; ! : AddAuditAccessAce ; ! : AddAuditAccessAceEx ; ! : AddAuditAccessObjectAce ; @@ -382,7 +509,7 @@ FUNCTION: BOOL GetUserNameW ( LPCTSTR lpBuffer, LPDWORD lpnSize ) ; ! : ImpersonateLoggedOnUser ; ! : ImpersonateNamedPipeClient ; ! : ImpersonateSelf ; -! : InitializeAcl ; +FUNCTION: BOOL InitializeAcl ( PACL pAcl, DWORD nAclLength, DWORD dwAclRevision ) ; ! : InitializeSecurityDescriptor ; ! : InitializeSid ; ! : InitiateSystemShutdownA ; @@ -508,70 +635,6 @@ FUNCTION: BOOL LookupPrivilegeValueW ( LPCTSTR lpSystemName, ! : OpenEventLogA ; ! : OpenEventLogW ; -! typedef enum _TOKEN_INFORMATION_CLASS { -: TokenUser 1 ; -: TokenGroups 2 ; -: TokenPrivileges 3 ; -: TokenOwner 4 ; -: TokenPrimaryGroup 5 ; -: TokenDefaultDacl 6 ; -: TokenSource 7 ; -: TokenType 8 ; -: TokenImpersonationLevel 9 ; -: TokenStatistics 10 ; -: TokenRestrictedSids 11 ; -: TokenSessionId 12 ; -: TokenGroupsAndPrivileges 13 ; -: TokenSessionReference 14 ; -: TokenSandBoxInert 15 ; -! } TOKEN_INFORMATION_CLASS; - -: DELETE HEX: 00010000 ; inline -: READ_CONTROL HEX: 00020000 ; inline -: WRITE_DAC HEX: 00040000 ; inline -: WRITE_OWNER HEX: 00080000 ; inline -: SYNCHRONIZE HEX: 00100000 ; inline -: STANDARD_RIGHTS_REQUIRED HEX: 000f0000 ; inline - -: STANDARD_RIGHTS_READ READ_CONTROL ; inline -: STANDARD_RIGHTS_WRITE READ_CONTROL ; inline -: STANDARD_RIGHTS_EXECUTE READ_CONTROL ; inline - -: TOKEN_TOKEN_ADJUST_DEFAULT HEX: 0080 ; inline -: TOKEN_ADJUST_GROUPS HEX: 0040 ; inline -: TOKEN_ADJUST_PRIVILEGES HEX: 0020 ; inline -: TOKEN_ADJUST_SESSIONID HEX: 0100 ; inline -: TOKEN_ASSIGN_PRIMARY HEX: 0001 ; inline -: TOKEN_DUPLICATE HEX: 0002 ; inline -: TOKEN_EXECUTE STANDARD_RIGHTS_EXECUTE ; inline -: TOKEN_IMPERSONATE HEX: 0004 ; inline -: TOKEN_QUERY HEX: 0008 ; inline -: TOKEN_QUERY_SOURCE HEX: 0010 ; inline -: TOKEN_ADJUST_DEFAULT HEX: 0080 ; inline -: TOKEN_READ STANDARD_RIGHTS_READ TOKEN_QUERY bitor ; - -: TOKEN_WRITE - { - STANDARD_RIGHTS_WRITE - TOKEN_ADJUST_PRIVILEGES - TOKEN_ADJUST_GROUPS - TOKEN_ADJUST_DEFAULT - } flags ; foldable - -: TOKEN_ALL_ACCESS - { - STANDARD_RIGHTS_REQUIRED - TOKEN_ASSIGN_PRIMARY - TOKEN_DUPLICATE - TOKEN_IMPERSONATE - TOKEN_QUERY - TOKEN_QUERY_SOURCE - TOKEN_ADJUST_PRIVILEGES - TOKEN_ADJUST_GROUPS - TOKEN_ADJUST_SESSIONID - TOKEN_ADJUST_DEFAULT - } flags ; foldable - FUNCTION: BOOL OpenProcessToken ( HANDLE ProcessHandle, DWORD DesiredAccess, PHANDLE TokenHandle ) ; From 56ff4530ff9b34fcc15050fd8af66b71e751b572 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 7 Apr 2008 19:28:54 -0500 Subject: [PATCH 04/15] fix blum-blum-shub --- .../blum-blum-shub-tests.factor | 28 +++++++++++++++++++ .../blum-blum-shub/blum-blum-shub.factor | 24 ++++++---------- 2 files changed, 36 insertions(+), 16 deletions(-) create mode 100644 extra/random/blum-blum-shub/blum-blum-shub-tests.factor diff --git a/extra/random/blum-blum-shub/blum-blum-shub-tests.factor b/extra/random/blum-blum-shub/blum-blum-shub-tests.factor new file mode 100644 index 0000000000..a92f256eeb --- /dev/null +++ b/extra/random/blum-blum-shub/blum-blum-shub-tests.factor @@ -0,0 +1,28 @@ +USING: kernel math tools.test namespaces random +random.blum-blum-shub ; +IN: blum-blum-shub.tests + +[ 887708070 ] [ + T{ blum-blum-shub f 590695557939 811977232793 } random-32* +] unit-test + + +[ 887708070 ] [ + T{ blum-blum-shub f 590695557939 811977232793 } [ + 32 random-bits + ] with-random +] unit-test + +[ 5726770047455156646 ] [ + T{ blum-blum-shub f 590695557939 811977232793 } [ + 64 random-bits + ] with-random +] unit-test + +[ 3716213681 ] +[ + 100 T{ blum-blum-shub f 200352954495 846054538649 } tuck [ + random-32* drop + ] curry times + random-32* +] unit-test diff --git a/extra/random/blum-blum-shub/blum-blum-shub.factor b/extra/random/blum-blum-shub/blum-blum-shub.factor index 017ef402c0..5644cf6d08 100755 --- a/extra/random/blum-blum-shub/blum-blum-shub.factor +++ b/extra/random/blum-blum-shub/blum-blum-shub.factor @@ -3,34 +3,26 @@ math.miller-rabin combinators.lib math.functions accessors random ; IN: random.blum-blum-shub -! TODO: take (log log M) bits instead of 1 bit -! Blum Blum Shub, M = pq +! Blum Blum Shub, n = pq, x_i+1 = x_i ^ 2 mod n +! return low bit of x+1 TUPLE: blum-blum-shub x n ; -C: blum-blum-shub + ( numbits -- blum-blum-shub ) - #! returns a Blum-Blum-Shub tuple generate-bbs-primes * [ find-relative-prime ] keep blum-blum-shub construct-boa ; -! 256 make-bbs blum-blum-shub set-global - : next-bbs-bit ( bbs -- bit ) - #! x = x^2 mod n, return low bit of calculated x - [ [ x>> 2 ] [ n>> ] bi ^mod ] - [ [ >>x ] keep x>> 1 bitand ] bi ; + [ [ x>> 2 ] [ n>> ] bi ^mod ] keep + over >>x drop 1 bitand ; -IN: crypto -! : random ( n -- n ) - ! ! #! Cryptographically secure random number using Blum-Blum-Shub 256 - ! [ log2 1+ random-bits ] keep dupd >= [ -1 shift ] when ; +PRIVATE> M: blum-blum-shub random-32* ( bbs -- r ) - ; + 0 32 rot + [ next-bbs-bit swap 1 shift bitor ] curry times ; From f0ae86b884efe75ab55d3f6e8524a019bafd80ac Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 7 Apr 2008 19:30:02 -0500 Subject: [PATCH 05/15] remove outdated file --- extra/crypto/test/blum-blum-shub.factor | 5 ----- 1 file changed, 5 deletions(-) delete mode 100644 extra/crypto/test/blum-blum-shub.factor diff --git a/extra/crypto/test/blum-blum-shub.factor b/extra/crypto/test/blum-blum-shub.factor deleted file mode 100644 index b1b6034373..0000000000 --- a/extra/crypto/test/blum-blum-shub.factor +++ /dev/null @@ -1,5 +0,0 @@ -USING: kernel math test namespaces crypto crypto-internals ; - -[ 6 ] [ 5 T{ bbs f 590695557939 811977232793 } random-bbs-bits* ] unit-test -[ 792723710536787233474130382522 ] [ 100 T{ bbs f 200352954495 846054538649 } [ random-bbs-bits* drop ] 2keep random-bbs-bits* ] unit-test - From b4c9bbdf805bc79256bc6f21f47d07cac0829251 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Wed, 9 Apr 2008 21:01:00 -0500 Subject: [PATCH 06/15] processing: at-fraction --- extra/processing/processing.factor | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) diff --git a/extra/processing/processing.factor b/extra/processing/processing.factor index 02a8325663..0f21634dc8 100644 --- a/extra/processing/processing.factor +++ b/extra/processing/processing.factor @@ -8,7 +8,7 @@ USING: kernel namespaces threads combinators sequences arrays combinators combinators.lib combinators.cleave - rewrite-closures fry accessors + rewrite-closures fry accessors newfx processing.color processing.gadget ; @@ -28,6 +28,12 @@ IN: processing ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +: at-fraction ( seq fraction -- val ) over length 1- * nth-at ; + +: at-fraction-of ( fraction seq -- val ) swap at-fraction ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + VAR: fill-color VAR: stroke-color @@ -282,7 +288,7 @@ VAR: frame-rate-value ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -VAR: slate +! VAR: slate VAR: loop-flag From a135aa479b9cf2c024e28a746dad0da9dea9093e Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Wed, 9 Apr 2008 21:01:34 -0500 Subject: [PATCH 07/15] bubble-chamber: Refactoring --- .../bubble-chamber/bubble-chamber.factor | 207 ++++++++---------- 1 file changed, 91 insertions(+), 116 deletions(-) diff --git a/extra/processing/gallery/bubble-chamber/bubble-chamber.factor b/extra/processing/gallery/bubble-chamber/bubble-chamber.factor index 2efa04efad..1a5fa37fa6 100644 --- a/extra/processing/gallery/bubble-chamber/bubble-chamber.factor +++ b/extra/processing/gallery/bubble-chamber/bubble-chamber.factor @@ -32,6 +32,8 @@ IN: processing.gallery.bubble-chamber : dim ( -- dim ) 1000 ; +: center ( -- point ) dim 2 / dup {2} ; foldable + ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! VAR: collision-theta @@ -73,7 +75,7 @@ VARS: particles muons quarks hadrons axions ; T{ rgba f 0.47 0.42 0.56 1 } } ; -: good-color ( i -- color ) good-colors nth-of ; +: anti-colors ( -- seq ) good-colors ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -89,6 +91,26 @@ VARS: particles muons quarks hadrons axions ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +: theta-dd-small? ( par limit -- par ? ) >r dup theta-dd>> abs r> < ; + +: random-theta-dd ( par a b -- par ) 2random >>theta-dd ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: turn ( particle -- particle ) + dup + [ speed>> ] [ theta>> { sin cos } ] bi n*v + >>vel ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: step-theta ( p -- p ) [ ] [ theta>> ] [ theta-d>> ] tri + >>theta ; +: step-theta-d ( p -- p ) [ ] [ theta-d>> ] [ theta-dd>> ] tri + >>theta-d ; +: step-speed-sub ( p -- p ) [ ] [ speed>> ] [ speed-d>> ] tri - >>speed ; +: step-speed-mul ( p -- p ) [ ] [ speed>> ] [ speed-d>> ] tri * >>speed ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + TUPLE: particle pos vel speed speed-d theta theta-d theta-dd myc mya ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -120,32 +142,36 @@ TUPLE: muon < particle ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +: color-fraction ( particle -- particle fraction ) dup theta>> pi + 2 pi * / ; + +: set-good-color ( particle -- particle ) + color-fraction dup 0 1 between? + [ good-colors at-fraction-of >>myc ] + [ drop ] + if ; + +: set-anti-color ( particle -- particle ) + color-fraction dup 0 1 between? + [ anti-colors at-fraction-of >>mya ] + [ drop ] + if ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + METHOD: collide { muon } - dim 2 / dup 2array >>pos - 2 32 [a,b] random >>speed - 0.0001 0.001 2random >>speed-d + center >>pos + 2 32 [a,b] random >>speed + 0.0001 0.001 2random >>speed-d collision-theta> -0.1 0.1 2random + >>theta 0 >>theta-d 0 >>theta-dd - [ dup theta-dd>> abs 0.001 < ] - [ -0.1 0.1 2random >>theta-dd ] - [ ] - while + [ 0.001 theta-dd-small? ] [ -0.1 0.1 random-theta-dd ] [ ] while - dup theta>> pi + - 2 pi * / - good-colors length 1 - * - [ ] [ good-colors length >= ] [ 0 < ] tri or - [ drop ] - [ - [ good-color >>myc ] - [ good-colors length swap - 1 - good-color >>mya ] - bi - ] - if + set-good-color + set-anti-color drop ; @@ -163,14 +189,11 @@ METHOD: move { muon } [ speed>> ] [ theta>> { sin cos } ] bi n*v move-by - [ ] [ theta>> ] [ theta-d>> ] tri + >>theta - [ ] [ theta-d>> ] [ theta-dd>> ] tri + >>theta-d - [ ] [ speed>> ] [ speed-d>> ] tri - >>speed + step-theta + step-theta-d + step-speed-sub - out-of-bounds? - [ collide ] - [ drop ] - if ; + out-of-bounds? [ collide ] [ drop ] if ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -182,7 +205,7 @@ TUPLE: quark < particle ; METHOD: collide { quark } - dim 2 / dup 2array >>pos + center >>pos collision-theta> -0.11 0.11 2random + >>theta 0.5 3.0 2random >>speed @@ -190,10 +213,7 @@ METHOD: collide { quark } 0 >>theta-d 0 >>theta-dd - [ dup theta-dd>> abs 0.00001 < ] - [ -0.001 0.001 2random >>theta-dd ] - [ ] - while + [ 0.00001 theta-dd-small? ] [ -0.001 0.001 random-theta-dd ] [ ] while drop ; @@ -208,26 +228,20 @@ METHOD: move { quark } [ ] [ vel>> ] bi move-by - dup - [ speed>> ] [ theta>> { sin cos } ] bi n*v - >>vel + turn - [ ] [ theta>> ] [ theta-d>> ] tri + >>theta - [ ] [ theta-d>> ] [ theta-dd>> ] tri + >>theta-d - [ ] [ speed>> ] [ speed-d>> ] tri * >>speed + step-theta + step-theta-d + step-speed-mul - ! 1000 random 997 > - 3/1000 chance + 1000 random 997 > [ dup speed>> neg >>speed 2 over speed-d>> - >>speed-d ] when - out-of-bounds? - [ collide ] - [ drop ] - if ; + out-of-bounds? [ collide ] [ drop ] if ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -239,18 +253,14 @@ TUPLE: hadron < particle ; METHOD: collide { hadron } - dim 2 / dup 2array >>pos - 2 pi * 1random >>theta - 0.5 3.5 2random >>speed - + center >>pos + 2 pi * 1random >>theta + 0.5 3.5 2random >>speed 0.996 1.001 2random >>speed-d 0 >>theta-d 0 >>theta-dd - [ dup theta-dd>> abs 0.00001 < ] - [ -0.001 0.001 2random >>theta-dd ] - [ ] - while + [ 0.00001 theta-dd-small? ] [ -0.001 0.001 random-theta-dd ] [ ] while 0 1 0 >>myc @@ -268,34 +278,22 @@ METHOD: move { hadron } dup vel>> move-by - dup - [ speed>> ] [ theta>> { sin cos } ] bi n*v - >>vel + turn - [ ] [ theta>> ] [ theta-d>> ] tri + >>theta - [ ] [ theta-d>> ] [ theta-dd>> ] tri + >>theta-d - [ ] [ speed>> ] [ speed-d>> ] tri * >>speed + step-theta + step-theta-d + step-speed-mul - ! 1000 random 997 > - 3/1000 chance + 1000 random 997 > [ 1.0 >>speed-d 0.00001 >>theta-dd - ! 100 random 70 > - 30/100 chance - [ - dim 2 / dup 2array >>pos - dup collide - ] - when + 100 random 70 > [ dup collide ] when ] when - out-of-bounds? - [ collide ] - [ drop ] - if ; + out-of-bounds? [ collide ] [ drop ] if ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -307,82 +305,59 @@ TUPLE: axion < particle ; METHOD: collide { axion } - dim 2 / dup 2array >>pos - 2 pi * 1random >>theta - 1.0 6.0 2random >>speed - + center >>pos + 2 pi * 1random >>theta + 1.0 6.0 2random >>speed 0.998 1.000 2random >>speed-d 0 >>theta-d 0 >>theta-dd - [ dup theta-dd>> abs 0.00001 < ] - [ -0.001 0.001 2random >>theta-dd ] - [ ] - while + [ 0.00001 theta-dd-small? ] [ -0.001 0.001 random-theta-dd ] [ ] while drop ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +: dy>alpha ( dy -- alpha ) neg 6 * 30 + 255.0 / ; + +: axion-white ( dy -- dy ) dup 1 swap dy>alpha {2} stroke ; +: axion-black ( dy -- dy ) dup 0 swap dy>alpha {2} stroke ; + +: axion-point- ( particle dy -- particle ) >r dup pos>> r> v-y point ; +: axion-point+ ( particle dy -- particle ) >r dup pos>> r> v+y point ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + METHOD: move { axion } { 0.06 0.59 } stroke dup pos>> point - 1 4 [a,b] - [| dy | - 1 30 dy 6 * - 255.0 / 2array stroke - dup pos>> 0 dy neg 2array v+ point - ] with-locals - each - - 1 4 [a,b] - [| dy | - 0 30 dy 6 * - 255.0 / 2array stroke - dup pos>> dy v+y point - ] with-locals - each + 1 4 [a,b] [ axion-white axion-point- ] each + 1 4 [a,b] [ axion-black axion-point+ ] each dup vel>> move-by - dup - [ speed>> ] [ theta>> { sin cos } ] bi n*v - >>vel + turn - [ ] [ theta>> ] [ theta-d>> ] tri + >>theta - [ ] [ theta-d>> ] [ theta-dd>> ] tri + >>theta-d - [ ] [ speed>> ] [ speed-d>> ] tri * >>speed + step-theta + step-theta-d + step-speed-mul [ ] [ speed-d>> 0.9999 * ] bi >>speed-d - ! 1000 random 996 > - 4/1000 chance + 1000 random 996 > [ - dup speed>> neg >>speed + dup speed>> neg >>speed dup speed-d>> neg 2 + >>speed-d - ! 100 random 30 > - 70/100 chance - [ - dim 2 / dup 2array >>pos - collide - ] - [ drop ] - if + 100 random 30 > [ collide ] [ drop ] if ] [ drop ] if ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! : draw ( -- ) - -! boom> -! [ particles> [ move ] each ] -! when ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - : collide-all ( -- ) 2 pi * 1random >collision-theta From 2a85901ccaa040bf0481108c43b12f22e4192dd7 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 10 Apr 2008 19:35:06 -0500 Subject: [PATCH 08/15] add some windows messages --- extra/windows/messages/messages.factor | 22 ++++++++++++++++++++++ 1 file changed, 22 insertions(+) diff --git a/extra/windows/messages/messages.factor b/extra/windows/messages/messages.factor index 733071d197..3b0db96d63 100644 --- a/extra/windows/messages/messages.factor +++ b/extra/windows/messages/messages.factor @@ -1001,3 +1001,25 @@ windows-messages set-global : LM_GETIDEALHEIGHT WM_USER HEX: 0301 + ; inline : LM_SETITEM WM_USER HEX: 0302 + ; inline : LM_GETITEM WM_USER HEX: 0303 + ; inline + + +: WA_INACTIVE 0 ; inline +: WA_ACTIVE 1 ; inline +: WA_CLICKACTIVE 2 ; inline + +: SC_SIZE HEX: f000 ; inline +: SC_MOVE HEX: f010 ; inline +: SC_MINIMIZE HEX: f020 ; inline +: SC_MAXIMIZE HEX: f030 ; inline +: SC_NEXTWINDOW HEX: f040 ; inline +: SC_PREVWINDOW HEX: f050 ; inline +: SC_CLOSE HEX: f060 ; inline +: SC_VSCROLL HEX: f070 ; inline +: SC_HSCROLL HEX: f080 ; inline +: SC_MOUSEMENU HEX: f090 ; inline +: SC_KEYMENU HEX: f100 ; inline +: SC_ARRANGE HEX: f110 ; inline +: SC_RESTORE HEX: f120 ; inline +: SC_TASKLIST HEX: f130 ; inline +: SC_SCREENSAVE HEX: f140 ; inline +: SC_HOTKEY HEX: f150 ; inline From 2cefe124d6c9c05b2b2dea665e7609ed63b85b3a Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 10 Apr 2008 21:17:23 -0500 Subject: [PATCH 09/15] try not to render to factor windows when they're minimized --- extra/ui/windows/windows.factor | 14 ++++++++++++-- 1 file changed, 12 insertions(+), 2 deletions(-) diff --git a/extra/ui/windows/windows.factor b/extra/ui/windows/windows.factor index e0c9f24122..0adfc676f8 100755 --- a/extra/ui/windows/windows.factor +++ b/extra/ui/windows/windows.factor @@ -7,7 +7,7 @@ vectors words windows.kernel32 windows.gdi32 windows.user32 windows.opengl32 windows.messages windows.types windows.nt windows threads libc combinators continuations command-line shuffle opengl ui.render unicode.case ascii math.bitfields -locals symbols ; +locals symbols accessors ; IN: ui.windows SINGLETON: windows-ui-backend @@ -203,8 +203,18 @@ SYMBOLS: msg-obj class-name-ptr mouse-captured ; wParam keystroke>gesture hWnd window-focus send-gesture drop ; +: set-window-active ( hwnd uMsg wParam lParam ? -- n ) + >r 4dup r> 2nip nip + swap window set-world-active? DefWindowProc ; + : handle-wm-syscommand ( hWnd uMsg wParam lParam -- n ) - dup alpha? [ 4drop 0 ] [ DefWindowProc ] if ; + { + { [ over SC_MINIMIZE = ] [ f set-window-active ] } + { [ over SC_RESTORE = ] [ t set-window-active ] } + { [ over SC_MAXIMIZE = ] [ t set-window-active ] } + { [ dup alpha? ] [ 4drop 0 ] } + { [ t ] [ DefWindowProc ] } + } cond ; : cleanup-window ( handle -- ) dup win-title [ free ] when* From a1b050fd88f5b3d3ba0a5b031dd1156d318e5b6a Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 10 Apr 2008 21:49:08 -0500 Subject: [PATCH 10/15] Fix interactor --- .../tools/interactor/interactor-tests.factor | 25 ++++++++++++++++++- extra/ui/tools/interactor/interactor.factor | 4 ++- 2 files changed, 27 insertions(+), 2 deletions(-) diff --git a/extra/ui/tools/interactor/interactor-tests.factor b/extra/ui/tools/interactor/interactor-tests.factor index fe0a654217..94953f9c72 100755 --- a/extra/ui/tools/interactor/interactor-tests.factor +++ b/extra/ui/tools/interactor/interactor-tests.factor @@ -1,4 +1,27 @@ IN: ui.tools.interactor.tests -USING: ui.tools.interactor tools.test ; +USING: ui.tools.interactor ui.gadgets.panes namespaces +ui.gadgets.editors concurrency.promises threads listener +tools.test kernel calendar ; \ must-infer + +[ ] [ "interactor" set ] unit-test + +[ ] [ "[ 1 2 3" "interactor" get set-editor-string ] unit-test + +[ ] [ "promise" set ] unit-test + +[ + "interactor" get stream-read-quot "promise" get fulfill +] "Interactor test" spawn drop + +! This should not throw an exception +[ ] [ "interactor" get evaluate-input ] unit-test + +[ ] [ [ "interactor" get interactor-busy? ] [ yield ] [ ] while ] unit-test + +[ ] [ "[ 1 2 3 ]" "interactor" get set-editor-string ] unit-test + +[ ] [ "interactor" get evaluate-input ] unit-test + +[ [ [ 1 2 3 ] ] ] [ "promise" get 5 seconds ?promise-timeout ] unit-test diff --git a/extra/ui/tools/interactor/interactor.factor b/extra/ui/tools/interactor/interactor.factor index 8232094e76..86ba51df95 100755 --- a/extra/ui/tools/interactor/interactor.factor +++ b/extra/ui/tools/interactor/interactor.factor @@ -138,7 +138,9 @@ M: interactor stream-read-partial drop parse-lines-interactive ] [ 2nip - dup delegate unexpected-eof? [ drop f ] when + dup parse-error? [ + dup error>> unexpected-eof? [ drop f ] when + ] when ] recover ; : handle-interactive ( lines interactor -- quot/f ? ) From 039c344e8745bc0f1a5afb975c0c57eb14eb1ea8 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 10 Apr 2008 22:02:23 -0500 Subject: [PATCH 11/15] Fix unit test failure on BSD --- extra/tools/vocabs/vocabs-tests.factor | 8 ++++++++ extra/tools/vocabs/vocabs.factor | 6 +++--- 2 files changed, 11 insertions(+), 3 deletions(-) create mode 100644 extra/tools/vocabs/vocabs-tests.factor diff --git a/extra/tools/vocabs/vocabs-tests.factor b/extra/tools/vocabs/vocabs-tests.factor new file mode 100644 index 0000000000..ae74d516e4 --- /dev/null +++ b/extra/tools/vocabs/vocabs-tests.factor @@ -0,0 +1,8 @@ +IN: tools.vocabs.tests +USING: tools.test tools.vocabs namespaces continuations ; + +[ ] [ + changed-vocabs get-global + f changed-vocabs set-global + [ "kernel" changed-vocab ] [ changed-vocabs set-global ] [ ] cleanup +] unit-test diff --git a/extra/tools/vocabs/vocabs.factor b/extra/tools/vocabs/vocabs.factor index 211b396c50..371bbc7813 100755 --- a/extra/tools/vocabs/vocabs.factor +++ b/extra/tools/vocabs/vocabs.factor @@ -76,11 +76,11 @@ SYMBOL: changed-vocabs [ f changed-vocabs set-global ] "tools.vocabs" add-init-hook : changed-vocab ( vocab -- ) - dup vocab - [ dup changed-vocabs get-global set-at ] [ drop ] if ; + dup vocab changed-vocabs get and + [ dup changed-vocabs get set-at ] [ drop ] if ; : unchanged-vocab ( vocab -- ) - changed-vocabs get-global delete-at ; + changed-vocabs get delete-at ; : unchanged-vocabs ( vocabs -- ) [ unchanged-vocab ] each ; From 1214f7e71334b2e355488471231b2f27d6c759ea Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Thu, 10 Apr 2008 22:31:12 -0500 Subject: [PATCH 12/15] newfx: Move to generics for getters and setters --- extra/newfx/newfx.factor | 91 +++++++++++++++++++++++++++++++--------- 1 file changed, 72 insertions(+), 19 deletions(-) diff --git a/extra/newfx/newfx.factor b/extra/newfx/newfx.factor index b123fef2a3..3df3b3ed05 100644 --- a/extra/newfx/newfx.factor +++ b/extra/newfx/newfx.factor @@ -1,56 +1,109 @@ USING: kernel sequences assocs qualified circular ; +USING: math multi-methods ; + QUALIFIED: sequences +QUALIFIED: assocs QUALIFIED: circular IN: newfx +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! Now, we can see a new world coming into view. ! A world in which there is the very real prospect of a new world order. ! ! - George Herbert Walker Bush +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +GENERIC: at ( col key -- val ) +GENERIC: of ( key col -- val ) ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: nth-at ( seq i -- val ) swap nth ; -: nth-of ( i seq -- val ) nth ; +GENERIC: grab ( col key -- col val ) ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: nth-is ( seq i val -- seq ) swap pick set-nth ; -: is-nth ( seq val i -- seq ) pick set-nth ; +GENERIC: is ( col key val -- col ) +GENERIC: as ( col val key -- col ) ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: nth-is-of ( i val seq -- seq ) dup >r swapd set-nth r> ; -: is-nth-of ( val i seq -- seq ) dup >r set-nth r> ; +GENERIC: is-of ( key val col -- col ) +GENERIC: as-of ( val key col -- col ) ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: mutate-nth ( seq i val -- ) swap rot set-nth ; -: mutate-nth-at ( seq val i -- ) rot set-nth ; - -: mutate-nth-of ( i val seq -- ) swapd set-nth ; -: mutate-nth-at-of ( val i seq -- ) set-nth ; +GENERIC: mutate-at ( col key val -- ) +GENERIC: mutate-as ( col val key -- ) ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: at-key ( tbl key -- val ) swap at ; -: key-of ( key tbl -- val ) at ; +GENERIC: at-mutate ( key val col -- ) +GENERIC: as-mutate ( val key col -- ) + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! sequence +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +METHOD: at { sequence number } swap nth ; +METHOD: of { number sequence } nth ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: key-is ( tbl key val -- tbl ) swap pick set-at ; -: is-key ( tbl val key -- tbl ) pick set-at ; +METHOD: grab { sequence number } dupd swap nth ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: mutate-key ( tbl key val -- ) swap rot set-at ; -: mutate-at-key ( tbl val key -- ) rot set-at ; +METHOD: is { sequence number object } swap pick set-nth ; +METHOD: as { sequence object number } pick set-nth ; -: mutate-key-of ( key val tbl -- ) swapd set-at ; -: mutate-at-key-of ( val key tbl -- ) set-at ; +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +METHOD: is-of { number object sequence } dup >r swapd set-nth r> ; +METHOD: as-of { object number sequence } dup >r set-nth r> ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +METHOD: mutate-at { sequence number object } swap rot set-nth ; +METHOD: mutate-as { sequence object number } rot set-nth ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +METHOD: at-mutate { number object sequence } swapd set-nth ; +METHOD: as-mutate { object number sequence } set-nth ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! assoc +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +METHOD: at { assoc object } swap assocs:at ; +METHOD: of { object assoc } assocs:at ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +METHOD: grab { assoc object } dupd swap assocs:at ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +METHOD: is { assoc object object } swap pick set-at ; +METHOD: as { assoc object object } pick set-at ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +METHOD: is-of { object object assoc } dup >r swapd set-at r> ; +METHOD: as-of { object object assoc } dup >r set-at r> ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +METHOD: mutate-at { assoc object object } swap rot set-at ; +METHOD: mutate-as { assoc object object } rot set-at ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +METHOD: at-mutate { object object assoc } swapd set-at ; +METHOD: as-mutate { object object assoc } set-at ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! From c71a46d15e23881c57a4359bf28e703ab0ea3978 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Thu, 10 Apr 2008 22:33:22 -0500 Subject: [PATCH 13/15] Remove bubble-chamber from gallery (moving to root) --- .../bubble-chamber/bubble-chamber-docs.factor | 97 ---- .../bubble-chamber/bubble-chamber.factor | 428 ------------------ 2 files changed, 525 deletions(-) delete mode 100644 extra/processing/gallery/bubble-chamber/bubble-chamber-docs.factor delete mode 100644 extra/processing/gallery/bubble-chamber/bubble-chamber.factor diff --git a/extra/processing/gallery/bubble-chamber/bubble-chamber-docs.factor b/extra/processing/gallery/bubble-chamber/bubble-chamber-docs.factor deleted file mode 100644 index 21a845e089..0000000000 --- a/extra/processing/gallery/bubble-chamber/bubble-chamber-docs.factor +++ /dev/null @@ -1,97 +0,0 @@ - -USING: help.syntax help.markup ; - -IN: processing.gallery.bubble-chamber - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -HELP: muon - - { $class-description - "The muon is a colorful particle with an entangled friend." - "It draws both itself and its horizontally symmetric partner." - "A high range of speed and almost no speed decay allow the" - "muon to reach the extents of the window, often forming rings" - "where theta has decayed but speed remains stable. The result" - "is color almost everywhere in the general direction of collision," - "stabilized into fuzzy rings." } ; - -HELP: quark - - { $class-description - "The quark draws as a translucent black. Their large numbers" - "create fields of blackness overwritten only by the glowing shadows of " - "Hadrons. " - "quarks are allowed to accelerate away with speed decay values above 1.0. " - "Each quark has an entangled friend. Both particles are drawn identically," - "mirrored along the y-axis." } ; - -HELP: hadron - - { $class-description - "Hadrons collide from totally random directions. " - "Those hadrons that do not exit the drawing area, " - "tend to stabilize into perfect circular orbits. " - "Each hadron draws with a slight glowing emboss. " - "The hadron itself is not drawn." } ; - -HELP: axion - - { $class-description - "The axion particle draws a bold black path. Axions exist " - "in a slightly higher dimension and as such are drawn with " - "elevated embossed shadows. Axions are quick to stabilize " - "and fall into single pixel orbits axions automatically " - "recollide themselves after stabilizing." } ; - -{ muon quark hadron axion } related-words - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -ARTICLE: "bubble-chamber" "Bubble Chamber" - - { $subsection "bubble-chamber-introduction" } - { $subsection "bubble-chamber-particles" } - { $subsection "bubble-chamber-author" } - { $subsection "bubble-chamber-running" } ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -ARTICLE: "bubble-chamber-introduction" "Introduction" - -"The Bubble Chamber is a generative painting system of imaginary " -"colliding particles. A single super-massive collision produces a " -"discrete universe of four particle types. Particles draw their " -"positions over time as pixel exposures. " ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -ARTICLE: "bubble-chamber-particles" "Particles" - -"Four types of particles exist. The behavior and graphic appearance of " -"each particle type is unique." - - { $subsection muon } - { $subsection quark } - { $subsection hadron } - { $subsection axion } ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -ARTICLE: "bubble-chamber-author" "Author" - - "Bubble Chamber was created by Jared Tarbell. " - "It was originally implemented in Processing. " - "It was ported to Factor by Eduardo Cavazos. " - "The original work is on display here: " - { $url - "http://www.complexification.net/gallery/machines/bubblechamber/" } ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -ARTICLE: "bubble-chamber-running" "How to use" - - "After you run the vocabulary, a window will appear. Click the " - "mouse in a random area to fire 11 particles of each type. " - "Another way to fire particles is to press the " - "spacebar. This fires all the particles." ; \ No newline at end of file diff --git a/extra/processing/gallery/bubble-chamber/bubble-chamber.factor b/extra/processing/gallery/bubble-chamber/bubble-chamber.factor deleted file mode 100644 index 1a5fa37fa6..0000000000 --- a/extra/processing/gallery/bubble-chamber/bubble-chamber.factor +++ /dev/null @@ -1,428 +0,0 @@ - -USING: kernel namespaces sequences combinators arrays threads - - math - math.libm - math.vectors - math.ranges - math.constants - math.functions - math.points - - ui - ui.gadgets - - random accessors multi-methods - combinators.cleave - vars locals - - newfx - - processing - processing.gadget - processing.color ; - -IN: processing.gallery.bubble-chamber - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: move-by ( obj delta -- obj ) over pos>> v+ >>pos ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: dim ( -- dim ) 1000 ; - -: center ( -- point ) dim 2 / dup {2} ; foldable - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -VAR: collision-theta - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -VAR: boom - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -VARS: particles muons quarks hadrons axions ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: good-colors ( -- seq ) - { - T{ rgba f 0.23 0.14 0.17 1 } - T{ rgba f 0.23 0.14 0.15 1 } - T{ rgba f 0.21 0.14 0.15 1 } - T{ rgba f 0.51 0.39 0.33 1 } - T{ rgba f 0.49 0.33 0.20 1 } - T{ rgba f 0.55 0.45 0.32 1 } - T{ rgba f 0.69 0.63 0.51 1 } - T{ rgba f 0.64 0.39 0.18 1 } - T{ rgba f 0.73 0.42 0.20 1 } - T{ rgba f 0.71 0.45 0.29 1 } - T{ rgba f 0.79 0.45 0.22 1 } - T{ rgba f 0.82 0.56 0.34 1 } - T{ rgba f 0.88 0.72 0.49 1 } - T{ rgba f 0.85 0.69 0.40 1 } - T{ rgba f 0.96 0.92 0.75 1 } - T{ rgba f 0.99 0.98 0.87 1 } - T{ rgba f 0.85 0.82 0.69 1 } - T{ rgba f 0.99 0.98 0.87 1 } - T{ rgba f 0.82 0.82 0.79 1 } - T{ rgba f 0.65 0.69 0.67 1 } - T{ rgba f 0.53 0.60 0.55 1 } - T{ rgba f 0.57 0.53 0.68 1 } - T{ rgba f 0.47 0.42 0.56 1 } - } ; - -: anti-colors ( -- seq ) good-colors ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: x ( particle -- x ) pos>> first ; -: y ( particle -- x ) pos>> second ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: out-of-bounds? ( particle -- particle ? ) - dup - { [ x dim neg < ] [ x dim 2 * > ] [ y dim neg < ] [ y dim 2 * > ] } cleave - or or or ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: theta-dd-small? ( par limit -- par ? ) >r dup theta-dd>> abs r> < ; - -: random-theta-dd ( par a b -- par ) 2random >>theta-dd ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: turn ( particle -- particle ) - dup - [ speed>> ] [ theta>> { sin cos } ] bi n*v - >>vel ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: step-theta ( p -- p ) [ ] [ theta>> ] [ theta-d>> ] tri + >>theta ; -: step-theta-d ( p -- p ) [ ] [ theta-d>> ] [ theta-dd>> ] tri + >>theta-d ; -: step-speed-sub ( p -- p ) [ ] [ speed>> ] [ speed-d>> ] tri - >>speed ; -: step-speed-mul ( p -- p ) [ ] [ speed>> ] [ speed-d>> ] tri * >>speed ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -TUPLE: particle pos vel speed speed-d theta theta-d theta-dd myc mya ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: initialize-particle ( particle -- particle ) - - 0 0 {2} >>pos - 0 0 {2} >>vel - - 0 >>speed - 0 >>speed-d - 0 >>theta - 0 >>theta-d - 0 >>theta-dd - - 0 0 0 1 >>myc - 0 0 0 1 >>mya ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -GENERIC: collide ( particle -- ) -GENERIC: move ( particle -- ) - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -TUPLE: muon < particle ; - -: ( -- muon ) muon construct-empty initialize-particle ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: color-fraction ( particle -- particle fraction ) dup theta>> pi + 2 pi * / ; - -: set-good-color ( particle -- particle ) - color-fraction dup 0 1 between? - [ good-colors at-fraction-of >>myc ] - [ drop ] - if ; - -: set-anti-color ( particle -- particle ) - color-fraction dup 0 1 between? - [ anti-colors at-fraction-of >>mya ] - [ drop ] - if ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -METHOD: collide { muon } - - center >>pos - 2 32 [a,b] random >>speed - 0.0001 0.001 2random >>speed-d - - collision-theta> -0.1 0.1 2random + >>theta - 0 >>theta-d - 0 >>theta-dd - - [ 0.001 theta-dd-small? ] [ -0.1 0.1 random-theta-dd ] [ ] while - - set-good-color - set-anti-color - - drop ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -METHOD: move { muon } - - dup myc>> 0.16 >>alpha stroke - dup pos>> point - - dup mya>> 0.16 >>alpha stroke - dup pos>> first2 >r dim swap - r> 2array point - - dup - [ speed>> ] [ theta>> { sin cos } ] bi n*v - move-by - - step-theta - step-theta-d - step-speed-sub - - out-of-bounds? [ collide ] [ drop ] if ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -TUPLE: quark < particle ; - -: ( -- quark ) quark construct-empty initialize-particle ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -METHOD: collide { quark } - - center >>pos - collision-theta> -0.11 0.11 2random + >>theta - 0.5 3.0 2random >>speed - - 0.996 1.001 2random >>speed-d - 0 >>theta-d - 0 >>theta-dd - - [ 0.00001 theta-dd-small? ] [ -0.001 0.001 random-theta-dd ] [ ] while - - drop ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -METHOD: move { quark } - - dup myc>> 0.13 >>alpha stroke - dup pos>> point - - dup pos>> first2 >r dim swap - r> 2array point - - [ ] [ vel>> ] bi move-by - - turn - - step-theta - step-theta-d - step-speed-mul - - 1000 random 997 > - [ - dup speed>> neg >>speed - 2 over speed-d>> - >>speed-d - ] - when - - out-of-bounds? [ collide ] [ drop ] if ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -TUPLE: hadron < particle ; - -: ( -- hadron ) hadron construct-empty initialize-particle ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -METHOD: collide { hadron } - - center >>pos - 2 pi * 1random >>theta - 0.5 3.5 2random >>speed - 0.996 1.001 2random >>speed-d - 0 >>theta-d - 0 >>theta-dd - - [ 0.00001 theta-dd-small? ] [ -0.001 0.001 random-theta-dd ] [ ] while - - 0 1 0 >>myc - - drop ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -METHOD: move { hadron } - - { 1 0.11 } stroke - dup pos>> 1 v-y point - - { 0 0.11 } stroke - dup pos>> 1 v+y point - - dup vel>> move-by - - turn - - step-theta - step-theta-d - step-speed-mul - - 1000 random 997 > - [ - 1.0 >>speed-d - 0.00001 >>theta-dd - - 100 random 70 > [ dup collide ] when - ] - when - - out-of-bounds? [ collide ] [ drop ] if ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -TUPLE: axion < particle ; - -: ( -- axion ) axion construct-empty initialize-particle ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -METHOD: collide { axion } - - center >>pos - 2 pi * 1random >>theta - 1.0 6.0 2random >>speed - 0.998 1.000 2random >>speed-d - 0 >>theta-d - 0 >>theta-dd - - [ 0.00001 theta-dd-small? ] [ -0.001 0.001 random-theta-dd ] [ ] while - - drop ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: dy>alpha ( dy -- alpha ) neg 6 * 30 + 255.0 / ; - -: axion-white ( dy -- dy ) dup 1 swap dy>alpha {2} stroke ; -: axion-black ( dy -- dy ) dup 0 swap dy>alpha {2} stroke ; - -: axion-point- ( particle dy -- particle ) >r dup pos>> r> v-y point ; -: axion-point+ ( particle dy -- particle ) >r dup pos>> r> v+y point ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -METHOD: move { axion } - - { 0.06 0.59 } stroke - dup pos>> point - - 1 4 [a,b] [ axion-white axion-point- ] each - 1 4 [a,b] [ axion-black axion-point+ ] each - - dup vel>> move-by - - turn - - step-theta - step-theta-d - step-speed-mul - - [ ] [ speed-d>> 0.9999 * ] bi >>speed-d - - 1000 random 996 > - [ - dup speed>> neg >>speed - dup speed-d>> neg 2 + >>speed-d - - 100 random 30 > [ collide ] [ drop ] if - ] - [ drop ] - if ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: collide-all ( -- ) - - 2 pi * 1random >collision-theta - - particles> [ collide ] each ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: collide-one ( -- ) - - dim 2 / mouse-x - dim 2 / mouse-y - fatan2 >collision-theta - - hadrons> random collide - quarks> random collide - muons> random collide ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: mouse-pressed ( -- ) - boom on - 1 background ! kludge - 11 [ drop collide-one ] each ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: key-released ( -- ) - key " " = - [ - boom on - 1 background - collide-all - ] - when ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: bubble-chamber ( -- ) - - 1000 1000 size* - - [ - 1 background - no-stroke - - 1789 [ drop ] map >muons - 1300 [ drop ] map >quarks - 1000 [ drop ] map >hadrons - 111 [ drop ] map >axions - - muons> quarks> hadrons> axions> 3append append >particles - - collide-one - ] setup - - [ - boom> - [ particles> [ move ] each ] - when - ] draw - - [ mouse-pressed ] button-down - [ key-released ] key-up - - ; - -: go ( -- ) [ bubble-chamber run ] with-ui ; - -MAIN: go \ No newline at end of file From bbf5234a9e1442d0561bc9b5e54ac99b7e742f0c Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Thu, 10 Apr 2008 22:34:26 -0500 Subject: [PATCH 14/15] processing: use 'at' --- extra/processing/processing.factor | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/extra/processing/processing.factor b/extra/processing/processing.factor index 0f21634dc8..e089b15e7e 100644 --- a/extra/processing/processing.factor +++ b/extra/processing/processing.factor @@ -28,7 +28,9 @@ IN: processing ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: at-fraction ( seq fraction -- val ) over length 1- * nth-at ; +! : at-fraction ( seq fraction -- val ) over length 1- * nth-at ; + +: at-fraction ( seq fraction -- val ) over length 1- * at ; : at-fraction-of ( fraction seq -- val ) swap at-fraction ; From cd9c92d9011b6675a2c4607c5cbece8ed051cbfa Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Thu, 10 Apr 2008 22:34:43 -0500 Subject: [PATCH 15/15] bubble-chamber: big refactoring --- extra/bubble-chamber/bubble-chamber.factor | 88 +++++++++++++++++++ extra/bubble-chamber/common/common.factor | 12 +++ .../particle/axion/axion.factor | 67 ++++++++++++++ .../particle/hadron/hadron.factor | 60 +++++++++++++ .../particle/muon/colors/colors.factor | 53 +++++++++++ .../bubble-chamber/particle/muon/muon.factor | 62 +++++++++++++ extra/bubble-chamber/particle/particle.factor | 68 ++++++++++++++ .../particle/quark/quark.factor | 53 +++++++++++ 8 files changed, 463 insertions(+) create mode 100644 extra/bubble-chamber/bubble-chamber.factor create mode 100644 extra/bubble-chamber/common/common.factor create mode 100644 extra/bubble-chamber/particle/axion/axion.factor create mode 100644 extra/bubble-chamber/particle/hadron/hadron.factor create mode 100644 extra/bubble-chamber/particle/muon/colors/colors.factor create mode 100644 extra/bubble-chamber/particle/muon/muon.factor create mode 100644 extra/bubble-chamber/particle/particle.factor create mode 100644 extra/bubble-chamber/particle/quark/quark.factor diff --git a/extra/bubble-chamber/bubble-chamber.factor b/extra/bubble-chamber/bubble-chamber.factor new file mode 100644 index 0000000000..4b0db46c35 --- /dev/null +++ b/extra/bubble-chamber/bubble-chamber.factor @@ -0,0 +1,88 @@ + +USING: kernel namespaces sequences random math math.constants math.libm vars + ui + processing + processing.gadget + bubble-chamber.common + bubble-chamber.particle + bubble-chamber.particle.muon + bubble-chamber.particle.quark + bubble-chamber.particle.hadron + bubble-chamber.particle.axion ; + +IN: bubble-chamber + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +VARS: particles muons quarks hadrons axions ; + +VAR: boom + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: collide-all ( -- ) + + 2 pi * 1random >collision-theta + + particles> [ collide ] each ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: collide-one ( -- ) + + dim 2 / mouse-x - dim 2 / mouse-y - fatan2 >collision-theta + + hadrons> random collide + quarks> random collide + muons> random collide ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: mouse-pressed ( -- ) + boom on + 1 background ! kludge + 11 [ drop collide-one ] each ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: key-released ( -- ) + key " " = + [ + boom on + 1 background + collide-all + ] + when ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: bubble-chamber ( -- ) + + 1000 1000 size* + + [ + 1 background + no-stroke + + 1789 [ drop ] map >muons + 1300 [ drop ] map >quarks + 1000 [ drop ] map >hadrons + 111 [ drop ] map >axions + + muons> quarks> hadrons> axions> 3append append >particles + + collide-one + ] setup + + [ + boom> + [ particles> [ move ] each ] + when + ] draw + + [ mouse-pressed ] button-down + [ key-released ] key-up ; + +: go ( -- ) [ bubble-chamber run ] with-ui ; + +MAIN: go \ No newline at end of file diff --git a/extra/bubble-chamber/common/common.factor b/extra/bubble-chamber/common/common.factor new file mode 100644 index 0000000000..c9ce687535 --- /dev/null +++ b/extra/bubble-chamber/common/common.factor @@ -0,0 +1,12 @@ + +USING: kernel math accessors combinators.cleave vars ; + +IN: bubble-chamber.common + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +VAR: collision-theta + +: dim ( -- dim ) 1000 ; + +: center ( -- point ) dim 2 / dup {2} ; foldable diff --git a/extra/bubble-chamber/particle/axion/axion.factor b/extra/bubble-chamber/particle/axion/axion.factor new file mode 100644 index 0000000000..9e9bf99272 --- /dev/null +++ b/extra/bubble-chamber/particle/axion/axion.factor @@ -0,0 +1,67 @@ + +USING: kernel sequences random accessors multi-methods + math math.constants math.ranges math.points combinators.cleave + processing bubble-chamber.common bubble-chamber.particle ; + +IN: bubble-chamber.particle.axion + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +TUPLE: axion < particle ; + +: ( -- axion ) axion construct-empty initialize-particle ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +METHOD: collide { axion } + + center >>pos + 2 pi * 1random >>theta + 1.0 6.0 2random >>speed + 0.998 1.000 2random >>speed-d + 0 >>theta-d + 0 >>theta-dd + + [ 0.00001 theta-dd-small? ] [ -0.001 0.001 random-theta-dd ] [ ] while + + drop ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: dy>alpha ( dy -- alpha ) neg 6 * 30 + 255.0 / ; + +: axion-white ( dy -- dy ) dup 1 swap dy>alpha {2} stroke ; +: axion-black ( dy -- dy ) dup 0 swap dy>alpha {2} stroke ; + +: axion-point- ( particle dy -- particle ) >r dup pos>> r> v-y point ; +: axion-point+ ( particle dy -- particle ) >r dup pos>> r> v+y point ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +METHOD: move { axion } + + { 0.06 0.59 } stroke + dup pos>> point + + 1 4 [a,b] [ axion-white axion-point- ] each + 1 4 [a,b] [ axion-black axion-point+ ] each + + dup vel>> move-by + + turn + + step-theta + step-theta-d + step-speed-mul + + [ ] [ speed-d>> 0.9999 * ] bi >>speed-d + + 1000 random 996 > + [ + dup speed>> neg >>speed + dup speed-d>> neg 2 + >>speed-d + + 100 random 30 > [ collide ] [ drop ] if + ] + [ drop ] + if ; diff --git a/extra/bubble-chamber/particle/hadron/hadron.factor b/extra/bubble-chamber/particle/hadron/hadron.factor new file mode 100644 index 0000000000..2994577838 --- /dev/null +++ b/extra/bubble-chamber/particle/hadron/hadron.factor @@ -0,0 +1,60 @@ + +USING: kernel random math math.constants math.points accessors multi-methods + processing + processing.color + bubble-chamber.common + bubble-chamber.particle ; + +IN: bubble-chamber.particle.hadron + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +TUPLE: hadron < particle ; + +: ( -- hadron ) hadron construct-empty initialize-particle ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +METHOD: collide { hadron } + + center >>pos + 2 pi * 1random >>theta + 0.5 3.5 2random >>speed + 0.996 1.001 2random >>speed-d + 0 >>theta-d + 0 >>theta-dd + + [ 0.00001 theta-dd-small? ] [ -0.001 0.001 random-theta-dd ] [ ] while + + 0 1 0 >>myc + + drop ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +METHOD: move { hadron } + + { 1 0.11 } stroke + dup pos>> 1 v-y point + + { 0 0.11 } stroke + dup pos>> 1 v+y point + + dup vel>> move-by + + turn + + step-theta + step-theta-d + step-speed-mul + + 1000 random 997 > + [ + 1.0 >>speed-d + 0.00001 >>theta-dd + + 100 random 70 > [ dup collide ] when + ] + when + + out-of-bounds? [ collide ] [ drop ] if ; diff --git a/extra/bubble-chamber/particle/muon/colors/colors.factor b/extra/bubble-chamber/particle/muon/colors/colors.factor new file mode 100644 index 0000000000..ab72f65b4b --- /dev/null +++ b/extra/bubble-chamber/particle/muon/colors/colors.factor @@ -0,0 +1,53 @@ + +USING: kernel sequences math math.constants accessors + processing + processing.color ; + +IN: bubble-chamber.particle.muon.colors + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: good-colors ( -- seq ) + { + T{ rgba f 0.23 0.14 0.17 1 } + T{ rgba f 0.23 0.14 0.15 1 } + T{ rgba f 0.21 0.14 0.15 1 } + T{ rgba f 0.51 0.39 0.33 1 } + T{ rgba f 0.49 0.33 0.20 1 } + T{ rgba f 0.55 0.45 0.32 1 } + T{ rgba f 0.69 0.63 0.51 1 } + T{ rgba f 0.64 0.39 0.18 1 } + T{ rgba f 0.73 0.42 0.20 1 } + T{ rgba f 0.71 0.45 0.29 1 } + T{ rgba f 0.79 0.45 0.22 1 } + T{ rgba f 0.82 0.56 0.34 1 } + T{ rgba f 0.88 0.72 0.49 1 } + T{ rgba f 0.85 0.69 0.40 1 } + T{ rgba f 0.96 0.92 0.75 1 } + T{ rgba f 0.99 0.98 0.87 1 } + T{ rgba f 0.85 0.82 0.69 1 } + T{ rgba f 0.99 0.98 0.87 1 } + T{ rgba f 0.82 0.82 0.79 1 } + T{ rgba f 0.65 0.69 0.67 1 } + T{ rgba f 0.53 0.60 0.55 1 } + T{ rgba f 0.57 0.53 0.68 1 } + T{ rgba f 0.47 0.42 0.56 1 } + } ; + +: anti-colors ( -- seq ) good-colors ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: color-fraction ( particle -- particle fraction ) dup theta>> pi + 2 pi * / ; + +: set-good-color ( particle -- particle ) + color-fraction dup 0 1 between? + [ good-colors at-fraction-of >>myc ] + [ drop ] + if ; + +: set-anti-color ( particle -- particle ) + color-fraction dup 0 1 between? + [ anti-colors at-fraction-of >>mya ] + [ drop ] + if ; diff --git a/extra/bubble-chamber/particle/muon/muon.factor b/extra/bubble-chamber/particle/muon/muon.factor new file mode 100644 index 0000000000..44c7d9f134 --- /dev/null +++ b/extra/bubble-chamber/particle/muon/muon.factor @@ -0,0 +1,62 @@ + +USING: kernel arrays sequences random + math + math.ranges + math.functions + math.vectors + multi-methods accessors + combinators.cleave + processing + bubble-chamber.common + bubble-chamber.particle + bubble-chamber.particle.muon.colors ; + +IN: bubble-chamber.particle.muon + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +TUPLE: muon < particle ; + +: ( -- muon ) muon construct-empty initialize-particle ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +METHOD: collide { muon } + + center >>pos + 2 32 [a,b] random >>speed + 0.0001 0.001 2random >>speed-d + + collision-theta> -0.1 0.1 2random + >>theta + 0 >>theta-d + 0 >>theta-dd + + [ 0.001 theta-dd-small? ] [ -0.1 0.1 random-theta-dd ] [ ] while + + set-good-color + set-anti-color + + drop ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +METHOD: move { muon } + + dup myc>> 0.16 >>alpha stroke + dup pos>> point + + dup mya>> 0.16 >>alpha stroke + dup pos>> first2 >r dim swap - r> 2array point + + dup + [ speed>> ] [ theta>> { sin cos } ] bi n*v + move-by + + step-theta + step-theta-d + step-speed-sub + + out-of-bounds? [ collide ] [ drop ] if ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + diff --git a/extra/bubble-chamber/particle/particle.factor b/extra/bubble-chamber/particle/particle.factor new file mode 100644 index 0000000000..755a414b71 --- /dev/null +++ b/extra/bubble-chamber/particle/particle.factor @@ -0,0 +1,68 @@ + +USING: kernel sequences combinators + math math.vectors math.functions multi-methods + accessors combinators.cleave processing processing.color + bubble-chamber.common ; + +IN: bubble-chamber.particle + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +GENERIC: collide ( particle -- ) +GENERIC: move ( particle -- ) + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +TUPLE: particle pos vel speed speed-d theta theta-d theta-dd myc mya ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: initialize-particle ( particle -- particle ) + + 0 0 {2} >>pos + 0 0 {2} >>vel + + 0 >>speed + 0 >>speed-d + 0 >>theta + 0 >>theta-d + 0 >>theta-dd + + 0 0 0 1 >>myc + 0 0 0 1 >>mya ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: move-by ( obj delta -- obj ) over pos>> v+ >>pos ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: theta-dd-small? ( par limit -- par ? ) >r dup theta-dd>> abs r> < ; + +: random-theta-dd ( par a b -- par ) 2random >>theta-dd ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: turn ( particle -- particle ) + dup + [ speed>> ] [ theta>> { sin cos } ] bi n*v + >>vel ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: step-theta ( p -- p ) [ ] [ theta>> ] [ theta-d>> ] tri + >>theta ; +: step-theta-d ( p -- p ) [ ] [ theta-d>> ] [ theta-dd>> ] tri + >>theta-d ; +: step-speed-sub ( p -- p ) [ ] [ speed>> ] [ speed-d>> ] tri - >>speed ; +: step-speed-mul ( p -- p ) [ ] [ speed>> ] [ speed-d>> ] tri * >>speed ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: x ( particle -- x ) pos>> first ; +: y ( particle -- x ) pos>> second ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: out-of-bounds? ( particle -- particle ? ) + dup + { [ x dim neg < ] [ x dim 2 * > ] [ y dim neg < ] [ y dim 2 * > ] } cleave + or or or ; diff --git a/extra/bubble-chamber/particle/quark/quark.factor b/extra/bubble-chamber/particle/quark/quark.factor new file mode 100644 index 0000000000..32d95c8f00 --- /dev/null +++ b/extra/bubble-chamber/particle/quark/quark.factor @@ -0,0 +1,53 @@ + +USING: kernel arrays sequences random math accessors multi-methods + processing + bubble-chamber.common + bubble-chamber.particle ; + +IN: bubble-chamber.particle.quark + +TUPLE: quark < particle ; + +: ( -- quark ) quark construct-empty initialize-particle ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +METHOD: collide { quark } + + center >>pos + collision-theta> -0.11 0.11 2random + >>theta + 0.5 3.0 2random >>speed + + 0.996 1.001 2random >>speed-d + 0 >>theta-d + 0 >>theta-dd + + [ 0.00001 theta-dd-small? ] [ -0.001 0.001 random-theta-dd ] [ ] while + + drop ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +METHOD: move { quark } + + dup myc>> 0.13 >>alpha stroke + dup pos>> point + + dup pos>> first2 >r dim swap - r> 2array point + + [ ] [ vel>> ] bi move-by + + turn + + step-theta + step-theta-d + step-speed-mul + + 1000 random 997 > + [ + dup speed>> neg >>speed + 2 over speed-d>> - >>speed-d + ] + when + + out-of-bounds? [ collide ] [ drop ] if ;