From b65feec3bdcc661b7110892deb6fc92f2f20cc77 Mon Sep 17 00:00:00 2001 From: Alex Chapman Date: Wed, 17 Sep 2008 19:35:30 +1000 Subject: [PATCH 01/19] Add http-put, and make any return code between 200 and 299 success. --- basis/http/client/client.factor | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/basis/http/client/client.factor b/basis/http/client/client.factor index 8dc1924a12..46bee405d1 100755 --- a/basis/http/client/client.factor +++ b/basis/http/client/client.factor @@ -141,7 +141,7 @@ PRIVATE> do-redirect ] with-variable ; -: success? ( code -- ? ) 200 = ; +: success? ( code -- ? ) 200 299 between? ; ERROR: download-failed response body ; @@ -183,3 +183,9 @@ M: download-failed error. : http-post ( post-data url -- response data ) http-request ; + +: ( data url -- request ) + "PUT" >>method ; + +: http-put ( data url -- response data ) + http-request ; From d7df5b22d20102a45e1010c203e0a04d299d15b4 Mon Sep 17 00:00:00 2001 From: Alex Chapman Date: Wed, 1 Oct 2008 10:38:54 +1000 Subject: [PATCH 02/19] adding initial couchdb --- extra/couchdb/authors.txt | 1 + extra/couchdb/couchdb-tests.factor | 4 +++ extra/couchdb/couchdb.factor | 43 ++++++++++++++++++++++++++++++ 3 files changed, 48 insertions(+) create mode 100644 extra/couchdb/authors.txt create mode 100644 extra/couchdb/couchdb-tests.factor create mode 100644 extra/couchdb/couchdb.factor diff --git a/extra/couchdb/authors.txt b/extra/couchdb/authors.txt new file mode 100644 index 0000000000..e9c193bac7 --- /dev/null +++ b/extra/couchdb/authors.txt @@ -0,0 +1 @@ +Alex Chapman diff --git a/extra/couchdb/couchdb-tests.factor b/extra/couchdb/couchdb-tests.factor new file mode 100644 index 0000000000..8907c0b811 --- /dev/null +++ b/extra/couchdb/couchdb-tests.factor @@ -0,0 +1,4 @@ +! Copyright (C) 2008 Alex Chapman +! See http://factorcode.org/license.txt for BSD license. +USING: tools.test couchdb ; +IN: couchdb.tests diff --git a/extra/couchdb/couchdb.factor b/extra/couchdb/couchdb.factor new file mode 100644 index 0000000000..7e1d97e786 --- /dev/null +++ b/extra/couchdb/couchdb.factor @@ -0,0 +1,43 @@ +! Copyright (C) 2008 Alex Chapman +! See http://factorcode.org/license.txt for BSD license. +USING: accessors arrays assocs continuations debugger http.client io json.reader json.writer kernel sequences strings ; +IN: couchdb + +TUPLE: server { base string initial: "http://localhost:5984" } ; + +TUPLE: db { server server } { name string } ; + +: db-path ( db -- path ) + [ server>> base>> ] [ name>> ] bi "/" swap 3array concat ; + +TUPLE: couchdb-error { data assoc } ; +C: couchdb-error + +M: couchdb-error error. ( error -- ) + "CouchDB Error: " write data>> + "error" over at [ print ] when* + "reason" swap at [ print ] when* ; + +PREDICATE: db-exists-error < couchdb-error + data>> "error" swap at [ + "database_already_exists" = + ] [ f ] if* ; + +: check-request ( response-data success? -- ) + [ drop ] [ throw ] if ; + +: couchdb-put ( request-data url -- json-response success? ) + (http-request) json> swap code>> success? ; + +USE: prettyprint + +: (create-db) ( db -- db json success? ) + f over db-path couchdb-put ; + +: create-db ( db -- db ) + (create-db) check-request ; + +: ensure-db ( db -- db ) + (create-db) [ drop ] [ + dup db-exists-error? [ drop ] [ throw ] if + ] if ; From 629289b46fe72f4c2b4dfa07c3e72221b4f8be29 Mon Sep 17 00:00:00 2001 From: Alex Chapman Date: Mon, 13 Oct 2008 17:01:29 +1100 Subject: [PATCH 03/19] Work on couchdb in progress. Added http-delete, http-trace, refactored some of http.client. --- basis/http/client/client.factor | 29 +++++++++++++++++++++-------- extra/couchdb/couchdb.factor | 13 +++++++++---- 2 files changed, 30 insertions(+), 12 deletions(-) diff --git a/basis/http/client/client.factor b/basis/http/client/client.factor index ef53e138ac..675258c79d 100644 --- a/basis/http/client/client.factor +++ b/basis/http/client/client.factor @@ -175,10 +175,14 @@ M: download-failed error. [ [ % ] with-http-request ] B{ } make over content-charset>> decode ; +: ( url -- request ) + swap >url ensure-port >>url ; + +: ( data url -- request ) + swap >>post-data ; + : ( url -- request ) - - "GET" >>method - swap >url ensure-port >>url ; + "GET" >>method ; : http-get ( url -- response data ) http-request ; @@ -186,6 +190,18 @@ M: download-failed error. : with-http-get ( url quot -- response ) [ ] dip with-http-request ; inline +: ( url -- request ) + "DELETE" >>method ; + +: http-delete ( url -- response data ) + http-request ; + +: ( url -- request ) + "TRACE" >>method ; + +: http-trace ( url -- response data ) + http-request ; + : download-name ( url -- name ) present file-name "?" split1 drop "/" ?tail drop ; @@ -196,16 +212,13 @@ M: download-failed error. dup download-name download-to ; : ( post-data url -- request ) - - "POST" >>method - swap >url ensure-port >>url - swap >>post-data ; + "POST" >>method ; : http-post ( post-data url -- response data ) http-request ; : ( data url -- request ) - "PUT" >>method ; + "PUT" >>method ; : http-put ( data url -- response data ) http-request ; diff --git a/extra/couchdb/couchdb.factor b/extra/couchdb/couchdb.factor index 7e1d97e786..7c656e175e 100644 --- a/extra/couchdb/couchdb.factor +++ b/extra/couchdb/couchdb.factor @@ -1,14 +1,16 @@ ! Copyright (C) 2008 Alex Chapman ! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays assocs continuations debugger http.client io json.reader json.writer kernel sequences strings ; +USING: accessors arrays assocs continuations debugger http.client io json.reader json.writer kernel sequences strings urls ; IN: couchdb -TUPLE: server { base string initial: "http://localhost:5984" } ; +TUPLE: db < url { url url initial: URL" http://localhost:5984" } ; +C: db -TUPLE: db { server server } { name string } ; +! : +: set-db-name ( db name : db-path ( db -- path ) - [ server>> base>> ] [ name>> ] bi "/" swap 3array concat ; + [ url>> ] [ name>> ] bi "/" swap 3array concat ; TUPLE: couchdb-error { data assoc } ; C: couchdb-error @@ -41,3 +43,6 @@ USE: prettyprint (create-db) [ drop ] [ dup db-exists-error? [ drop ] [ throw ] if ] if ; + +: delete-db ( db -- ) + From 868ad064261efec4a197c4a2ff1df4dc56ddbccb Mon Sep 17 00:00:00 2001 From: Alex Chapman Date: Tue, 14 Oct 2008 15:05:05 +1100 Subject: [PATCH 04/19] Adding hats --- extra/hats/authors.txt | 1 + extra/hats/hats-tests.factor | 87 ++++++++++++++++++++++++++++++++++++ extra/hats/hats.factor | 57 +++++++++++++++++++++++ extra/hats/summary.txt | 1 + 4 files changed, 146 insertions(+) create mode 100644 extra/hats/authors.txt create mode 100644 extra/hats/hats-tests.factor create mode 100644 extra/hats/hats.factor create mode 100644 extra/hats/summary.txt diff --git a/extra/hats/authors.txt b/extra/hats/authors.txt new file mode 100644 index 0000000000..e9c193bac7 --- /dev/null +++ b/extra/hats/authors.txt @@ -0,0 +1 @@ +Alex Chapman diff --git a/extra/hats/hats-tests.factor b/extra/hats/hats-tests.factor new file mode 100644 index 0000000000..ebb61a0830 --- /dev/null +++ b/extra/hats/hats-tests.factor @@ -0,0 +1,87 @@ +! Copyright (C) 2008 Alex Chapman. +! See http://factorcode.org/license.txt for BSD license. +USING: boxes hats kernel namespaces symbols tools.test ; +IN: hats.tests + +SYMBOLS: lion giraffe elephant rabbit ; + +! caps +[ rabbit ] [ rabbit out ] unit-test +[ rabbit ] [ f rabbit in out ] unit-test +[ rabbit ] [ rabbit take ] unit-test +[ f ] [ rabbit empty-hat out ] unit-test +[ rabbit f ] [ rabbit [ take ] keep out ] unit-test +[ rabbit t ] [ rabbit [ take ] keep empty-hat? ] unit-test +[ lion ] [ rabbit [ drop lion ] change-hat out ] unit-test + +! bowlers +[ giraffe ] [ [ giraffe rabbit set rabbit out ] with-scope ] unit-test + +[ rabbit ] +[ + [ + lion rabbit set [ + rabbit rabbit set rabbit out + ] with-scope + ] with-scope +] unit-test + +[ rabbit ] [ + rabbit + [ + lion rabbit set [ + rabbit rabbit set out + ] with-scope + ] with-scope +] unit-test + +[ elephant ] [ + rabbit + [ + elephant rabbit set [ + rabbit rabbit set + ] with-scope + out + ] with-scope +] unit-test + +[ rabbit ] [ + rabbit + [ + elephant in [ + rabbit in out + ] with-scope + ] with-scope +] unit-test + +[ elephant ] [ + rabbit + [ + elephant in [ + rabbit in + ] with-scope + out + ] with-scope +] unit-test + +! Top Hats +[ lion ] [ lion rabbit set-global rabbit out ] unit-test +[ giraffe ] [ rabbit giraffe in out ] unit-test + +! Tuple hats +TUPLE: foo bar ; +C: foo + +: test-tuple ( -- tuple ) + rabbit ; + +: test-slot-hat ( -- slot-hat ) + test-tuple 2 ; ! hack! + +[ rabbit ] [ test-slot-hat out ] unit-test +[ lion ] [ test-slot-hat lion in out ] unit-test + +! Boxes as hats +[ rabbit ] [ rabbit in out ] unit-test +[ rabbit in lion in ] must-fail +[ out ] must-fail diff --git a/extra/hats/hats.factor b/extra/hats/hats.factor new file mode 100644 index 0000000000..113705bd11 --- /dev/null +++ b/extra/hats/hats.factor @@ -0,0 +1,57 @@ +! Copyright (C) 2008 Alex Chapman. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors boxes kernel namespaces ; +IN: hats + +! Bullwinkle: Hey Rocky, watch me pull a rabbit out of my hat! +! Rocky: But that trick never works! +! Bullwinkle: This time for sure! + +! hat protocol +MIXIN: hat + +GENERIC: out ( hat -- object ) +GENERIC: (in) ( object hat -- ) + +: in ( hat object -- hat ) over (in) ; inline +: empty-hat? ( hat -- ? ) out not ; inline +: empty-hat ( hat -- hat ) f in ; inline +: take ( hat -- object ) dup out f rot (in) ; inline +: change-hat ( hat quot -- hat ) + over >r >r out r> call r> swap in ; inline + +! caps (the simplest of hats) +TUPLE: cap object ; +C: cap +M: cap out ( cap -- object ) object>> ; +M: cap (in) ( object cap -- ) (>>object) ; +INSTANCE: cap hat + +! bowlers (dynamic variable hats) +TUPLE: bowler variable ; +C: bowler +M: bowler out ( bowler -- object ) variable>> get ; +M: bowler (in) ( object bowler -- ) variable>> set ; +INSTANCE: bowler hat + +! Top Hats (global variable hats) +TUPLE: top-hat variable ; +C: top-hat +M: top-hat out ( top-hat -- object ) variable>> get-global ; +M: top-hat (in) ( object top-hat -- ) variable>> set-global ; +INSTANCE: top-hat hat + +USE: slots.private +! Slot hats +TUPLE: slot-hat tuple slot ; +C: slot-hat +: >slot-hat< ( slot-hat -- tuple slot ) [ tuple>> ] [ slot>> ] bi ; inline +M: slot-hat out ( slot-hat -- object ) >slot-hat< slot ; +M: slot-hat (in) ( object slot-hat -- ) >slot-hat< set-slot ; +INSTANCE: slot-hat hat + +! Put a box on your head +M: box out ( box -- object ) box> ; +M: box (in) ( object box -- ) >box ; +INSTANCE: box hat + diff --git a/extra/hats/summary.txt b/extra/hats/summary.txt new file mode 100644 index 0000000000..9590639922 --- /dev/null +++ b/extra/hats/summary.txt @@ -0,0 +1 @@ +A protocol for getting and setting From 59e76f4d13b99e38fdb776437a9613651678a3a0 Mon Sep 17 00:00:00 2001 From: Alex Chapman Date: Sat, 1 Nov 2008 15:35:23 +1100 Subject: [PATCH 05/19] Changes to http.client for couchdb I made the download-failed error contain the data returned by the server. --- basis/http/client/client.factor | 25 +++++++++++++------------ 1 file changed, 13 insertions(+), 12 deletions(-) diff --git a/basis/http/client/client.factor b/basis/http/client/client.factor index 675258c79d..6d8d97e040 100644 --- a/basis/http/client/client.factor +++ b/basis/http/client/client.factor @@ -52,7 +52,8 @@ M: f >post-data ; [ >post-data ] change-post-data ; : write-post-data ( request -- request ) - dup method>> "POST" = [ dup post-data>> raw>> write ] when ; + dup method>> [ "POST" = ] [ "PUT" = ] bi or + [ dup post-data>> [ raw>> write ] when* ] when ; : write-request ( request -- ) unparse-post-data @@ -90,7 +91,7 @@ M: too-many-redirects summary >method swap (with-http-request) + "GET" >>method swap with-http-request ] [ too-many-redirects ] if ; inline recursive : read-chunk-size ( -- n ) @@ -133,7 +134,7 @@ SYMBOL: redirects request get url>> url-addr ascii drop 1 minutes over set-timeout ; -: (with-http-request) ( request quot: ( chunk -- ) -- response ) +: with-http-request ( request quot: ( chunk -- ) -- response ) swap request [ [ @@ -159,21 +160,21 @@ PRIVATE> : success? ( code -- ? ) 200 299 between? ; -ERROR: download-failed response ; +ERROR: download-failed response data ; M: download-failed error. "HTTP request failed:" print nl - response>> . ; + [ response>> . ] [ data>> . ] bi ; + +: check-response* ( response data -- response data ) + over code>> success? [ download-failed ] unless ; : check-response ( response -- response ) - dup code>> success? [ download-failed ] unless ; - -: with-http-request ( request quot -- response ) - (with-http-request) check-response ; inline + f check-response* drop ; : http-request ( request -- response data ) [ [ % ] with-http-request ] B{ } make - over content-charset>> decode ; + over content-charset>> decode check-response* ; : ( url -- request ) swap >url ensure-port >>url ; @@ -188,7 +189,7 @@ M: download-failed error. http-request ; : with-http-get ( url quot -- response ) - [ ] dip with-http-request ; inline + [ ] dip with-http-request check-response ; inline : ( url -- request ) "DELETE" >>method ; From e05db8fc44f0c3303cbede967dfaccb828e14df4 Mon Sep 17 00:00:00 2001 From: Alex Chapman Date: Sat, 1 Nov 2008 15:36:56 +1100 Subject: [PATCH 06/19] CouchDB working and able to create/load/save/delete docs --- extra/couchdb/couchdb.factor | 187 ++++++++++++++++++++++++++++++----- 1 file changed, 161 insertions(+), 26 deletions(-) diff --git a/extra/couchdb/couchdb.factor b/extra/couchdb/couchdb.factor index 7c656e175e..8829a59779 100644 --- a/extra/couchdb/couchdb.factor +++ b/extra/couchdb/couchdb.factor @@ -1,17 +1,17 @@ ! Copyright (C) 2008 Alex Chapman ! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays assocs continuations debugger http.client io json.reader json.writer kernel sequences strings urls ; +USING: accessors arrays assocs continuations debugger hashtables http http.client io json.reader json.writer kernel make math math.parser namespaces sequences strings urls vectors ; IN: couchdb -TUPLE: db < url { url url initial: URL" http://localhost:5984" } ; -C: db +! NOTE: This code only works with the latest couchdb (0.9.*), because old +! versions didn't provide the /_uuids feature which this code relies on when +! creating new documents. -! : - -: set-db-name ( db name -: db-path ( db -- path ) - [ url>> ] [ name>> ] bi "/" swap 3array concat ; +SYMBOL: couch +: with-couch ( db quot -- ) + couch swap with-variable ; inline +! errors TUPLE: couchdb-error { data assoc } ; C: couchdb-error @@ -20,29 +20,164 @@ M: couchdb-error error. ( error -- ) "error" over at [ print ] when* "reason" swap at [ print ] when* ; -PREDICATE: db-exists-error < couchdb-error - data>> "error" swap at [ - "database_already_exists" = - ] [ f ] if* ; +PREDICATE: file-exists-error < couchdb-error + data>> "error" swap at "file_exists" = ; -: check-request ( response-data success? -- ) - [ drop ] [ throw ] if ; +! http tools +: couch-http-request ( request -- data ) + [ http-request ] [ + dup download-failed? [ + data>> json> throw + ] [ + rethrow + ] if + ] recover nip ; -: couchdb-put ( request-data url -- json-response success? ) - (http-request) json> swap code>> success? ; +: couch-request ( request -- assoc ) + couch-http-request json> ; -USE: prettyprint +: couch-get ( url -- assoc ) + couch-request ; -: (create-db) ( db -- db json success? ) - f over db-path couchdb-put ; +: couch-put ( post-data url -- assoc ) + couch-request ; -: create-db ( db -- db ) - (create-db) check-request ; +: couch-post ( post-data url -- assoc ) + couch-request ; -: ensure-db ( db -- db ) - (create-db) [ drop ] [ - dup db-exists-error? [ drop ] [ throw ] if - ] if ; +: couch-delete ( url -- assoc ) + couch-request ; + +: response-ok ( assoc -- assoc ) + "ok" over delete-at* and t assert= ; + +: response-ok* ( assoc -- ) + response-ok drop ; + +! server +TUPLE: server { host string } { port integer } { uuids vector } { uuids-to-cache integer } ; + +: default-couch-host "localhost" ; +: default-couch-port 5984 ; +: default-uuids-to-cache 100 ; + +: ( host port -- server ) + V{ } clone default-uuids-to-cache server boa ; + +: ( -- server ) + default-couch-host default-couch-port ; + +: (server-url) ( server -- ) + "http://" % [ host>> % ] [ CHAR: : , port>> number>string % ] bi CHAR: / , ; inline + +: server-url ( server -- url ) + [ (server-url) ] "" make ; + +: all-dbs ( server -- dbs ) + server-url "_all_dbs" append couch-get ; + +: uuids-url ( server -- url ) + [ dup server-url % "_uuids?count=" % uuids-to-cache>> number>string % ] "" make ; + +: uuids-post ( server -- uuids ) + uuids-url f swap couch-post "uuids" swap at >vector ; + +: get-uuids ( server -- server ) + dup uuids-post [ nip ] curry change-uuids ; + +: ensure-uuids ( server -- server ) + dup uuids>> empty? [ get-uuids ] when ; + +: next-uuid ( server -- uuid ) + ensure-uuids uuids>> pop ; + +! db +TUPLE: db { server server } { name string } ; +C: db + +: (db-url) ( db -- ) + [ server>> server-url % ] [ name>> % ] bi CHAR: / , ; inline + +: db-url ( db -- url ) + [ (db-url) ] "" make ; + +: create-db ( db -- ) + f swap db-url couch-put response-ok* ; + +: ensure-db ( db -- ) + [ create-db ] [ + dup file-exists-error? [ 2drop ] [ rethrow ] if + ] recover ; : delete-db ( db -- ) - + db-url couch-delete drop ; + +: db-info ( db -- info ) + db-url couch-get ; + +: compact-db ( db -- ) + f swap db-url "_compact" append couch-post response-ok* ; + +: all-docs ( db -- docs ) + ! TODO: queries. Maybe pass in a hashtable with options + db-url "_all_docs" append couch-get ; + +: ( assoc -- post-data ) + >json "application/json" ; + +! documents +: id> ( assoc -- id ) "_id" swap at ; +: >id ( assoc id -- assoc ) "_id" pick set-at ; +: rev> ( assoc -- rev ) "_rev" swap at ; +: >rev ( assoc rev -- assoc ) "_rev" pick set-at ; + +: copy-key ( to from to-key from-key -- ) + rot at spin set-at ; + +: copy-id ( to from -- ) + "_id" "id" copy-key ; + +: copy-rev ( to from -- ) + "_rev" "rev" copy-key ; + +: id-url ( id -- url ) + couch get db-url swap append ; + +: doc-url ( assoc -- url ) + id> id-url ; + +: new-doc-url ( -- url ) + couch get [ db-url ] [ server>> next-uuid ] bi append ; + +: save-new ( assoc -- ) + dup new-doc-url couch-put response-ok + [ copy-id ] [ copy-rev ] 2bi ; + +: save-existing ( assoc id -- ) + [ dup ] dip id-url couch-put response-ok copy-rev ; + +: save ( assoc -- ) + dup id> [ save-existing ] [ save-new ] if* ; + +: load ( id -- assoc ) + id-url couch-get ; + +: delete ( assoc -- ) + [ + [ doc-url % ] + [ "?rev=" % "_rev" swap at % ] bi + ] "" make couch-delete response-ok* ; + +: remove-keys ( assoc keys -- ) + swap [ delete-at ] curry each ; + +: remove-couch-info ( assoc -- ) + { "_id" "_rev" "_attachments" } remove-keys ; + +! TODO: +! - startkey, count, descending, etc. +! - loading specific revisions +! - views +! - attachments +! - bulk insert/update +! - ...? From eb36537e99c4779c0dee3c4b9033f786aa77ac62 Mon Sep 17 00:00:00 2001 From: Alex Chapman Date: Sat, 1 Nov 2008 20:38:50 +1100 Subject: [PATCH 07/19] Added some unit tests to couchdb --- extra/couchdb/couchdb-tests.factor | 43 +++++++++++++++++++++++++++++- extra/couchdb/couchdb.factor | 40 ++++++++++++++++++--------- 2 files changed, 69 insertions(+), 14 deletions(-) diff --git a/extra/couchdb/couchdb-tests.factor b/extra/couchdb/couchdb-tests.factor index 8907c0b811..7e38f5c2ee 100644 --- a/extra/couchdb/couchdb-tests.factor +++ b/extra/couchdb/couchdb-tests.factor @@ -1,4 +1,45 @@ ! Copyright (C) 2008 Alex Chapman ! See http://factorcode.org/license.txt for BSD license. -USING: tools.test couchdb ; +USING: assocs couchdb kernel namespaces sequences strings tools.test ; IN: couchdb.tests + +! You must have a CouchDB server (currently only the version from svn will +! work) running on localhost and listening on the default port for these tests +! to work. + + "factor-test" [ + [ ] [ couch get create-db ] unit-test + [ couch get create-db ] must-fail + [ ] [ couch get delete-db ] unit-test + [ couch get delete-db ] must-fail + [ ] [ couch get ensure-db ] unit-test + [ ] [ couch get ensure-db ] unit-test + [ 0 ] [ couch get db-info "doc_count" swap at ] unit-test + [ ] [ couch get compact-db ] unit-test + [ ] [ H{ + { "Subject" "I like Planktion" } + { "Tags" { "plankton" "baseball" "decisions" } } + { "Body" + "I decided today that I don't like baseball. I like plankton." } + { "Author" "Rusty" } + { "PostedDate" "2006-08-15T17:30:12Z-04:00" } + } save-doc ] unit-test + [ t ] [ couch get all-docs "rows" swap at first "id" swap at dup "id" set string? ] unit-test + [ t ] [ "id" get dup load-doc id> = ] unit-test + [ ] [ "id" get load-doc save-doc ] unit-test + [ "Rusty" ] [ "id" get load-doc "Author" swap at ] unit-test + [ ] [ "id" get load-doc "Alex" "Author" pick set-at save-doc ] unit-test + [ "Alex" ] [ "id" get load-doc "Author" swap at ] unit-test + [ 1 ] [ "function(doc) { emit(null, doc) }" temp-view-map "total_rows" swap at ] unit-test + [ ] [ H{ + { "_id" "_design/posts" } + { "language" "javascript" } + { "views" H{ + { "all" H{ { "map" "function(doc) { emit(null, doc) }" } } } + } + } + } save-doc ] unit-test + [ t ] [ "id" get load-doc delete-doc string? ] unit-test + [ "id" get load-doc ] must-fail + [ ] [ couch get delete-db ] unit-test +] with-couch diff --git a/extra/couchdb/couchdb.factor b/extra/couchdb/couchdb.factor index 8829a59779..3419244d72 100644 --- a/extra/couchdb/couchdb.factor +++ b/extra/couchdb/couchdb.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Alex Chapman ! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays assocs continuations debugger hashtables http http.client io json.reader json.writer kernel make math math.parser namespaces sequences strings urls vectors ; +USING: accessors arrays assocs continuations debugger hashtables http http.client io json.reader json.writer kernel make math math.parser namespaces sequences strings urls urls.encoding vectors ; IN: couchdb ! NOTE: This code only works with the latest couchdb (0.9.*), because old @@ -130,6 +130,8 @@ C: db : >id ( assoc id -- assoc ) "_id" pick set-at ; : rev> ( assoc -- rev ) "_rev" swap at ; : >rev ( assoc rev -- assoc ) "_rev" pick set-at ; +: attachments> ( assoc -- attachments ) "_attachments" swap at ; +: >attachments ( assoc attachments -- assoc ) "_attachments" pick set-at ; : copy-key ( to from to-key from-key -- ) rot at spin set-at ; @@ -141,32 +143,35 @@ C: db "_rev" "rev" copy-key ; : id-url ( id -- url ) - couch get db-url swap append ; + couch get db-url swap url-encode-full append ; : doc-url ( assoc -- url ) id> id-url ; -: new-doc-url ( -- url ) - couch get [ db-url ] [ server>> next-uuid ] bi append ; +: temp-view ( view -- results ) + couch get db-url "_temp_view" append couch-post ; -: save-new ( assoc -- ) - dup new-doc-url couch-put response-ok +: temp-view-map ( map -- results ) + "map" H{ } clone [ set-at ] keep temp-view ; + +: save-doc-as ( assoc id -- ) + [ dup ] dip id-url couch-put response-ok [ copy-id ] [ copy-rev ] 2bi ; -: save-existing ( assoc id -- ) - [ dup ] dip id-url couch-put response-ok copy-rev ; +: save-new-doc ( assoc -- ) + couch get server>> next-uuid save-doc-as ; -: save ( assoc -- ) - dup id> [ save-existing ] [ save-new ] if* ; +: save-doc ( assoc -- ) + dup id> [ save-doc-as ] [ save-new-doc ] if* ; -: load ( id -- assoc ) +: load-doc ( id -- assoc ) id-url couch-get ; -: delete ( assoc -- ) +: delete-doc ( assoc -- deletion-revision ) [ [ doc-url % ] [ "?rev=" % "_rev" swap at % ] bi - ] "" make couch-delete response-ok* ; + ] "" make couch-delete response-ok "rev" swap at ; : remove-keys ( assoc keys -- ) swap [ delete-at ] curry each ; @@ -174,6 +179,15 @@ C: db : remove-couch-info ( assoc -- ) { "_id" "_rev" "_attachments" } remove-keys ; +! : construct-attachment ( content-type data -- assoc ) +! H{ } clone "name" pick set-at "content-type" pick set-at ; +! +! : add-attachment ( assoc name attachment -- ) +! pick attachments> [ H{ } clone ] unless* +! +! : attach ( assoc name content-type data -- ) +! construct-attachment H{ } clone + ! TODO: ! - startkey, count, descending, etc. ! - loading specific revisions From 030619114f1bae1fb5a3b59fa7b79f4653057720 Mon Sep 17 00:00:00 2001 From: Alex Chapman Date: Sat, 1 Nov 2008 20:39:18 +1100 Subject: [PATCH 08/19] Un-privatising a word in http.client --- basis/http/client/client.factor | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/basis/http/client/client.factor b/basis/http/client/client.factor index 6d8d97e040..e6435ee12b 100644 --- a/basis/http/client/client.factor +++ b/basis/http/client/client.factor @@ -89,10 +89,10 @@ M: too-many-redirects summary drop [ "Redirection limit of " % max-redirects # " exceeded" % ] "" make ; -> url-addr ascii drop 1 minutes over set-timeout ; +PRIVATE> + : with-http-request ( request quot: ( chunk -- ) -- response ) swap request [ @@ -156,8 +158,6 @@ SYMBOL: redirects [ do-redirect ] [ nip ] if ] with-variable ; inline recursive -PRIVATE> - : success? ( code -- ? ) 200 299 between? ; ERROR: download-failed response data ; From 4e268ea5670a6d9f3a7886a1e47ea39b608eecf5 Mon Sep 17 00:00:00 2001 From: Alex Chapman Date: Sat, 1 Nov 2008 20:40:07 +1100 Subject: [PATCH 09/19] Adding url-encode-full to urls.encoding to do url encoding properly --- basis/urls/encoding/encoding-docs.factor | 6 +++++- basis/urls/encoding/encoding.factor | 24 ++++++++++++++++++++++++ 2 files changed, 29 insertions(+), 1 deletion(-) diff --git a/basis/urls/encoding/encoding-docs.factor b/basis/urls/encoding/encoding-docs.factor index f8b435441f..82ab3d1f69 100644 --- a/basis/urls/encoding/encoding-docs.factor +++ b/basis/urls/encoding/encoding-docs.factor @@ -7,7 +7,11 @@ HELP: url-decode HELP: url-encode { $values { "str" string } { "encoded" string } } -{ $description "URL-encodes a string." } ; +{ $description "URL-encodes a string, excluding certain characters, such as \"/\"." } ; + +HELP: url-encode-full +{ $values { "str" string } { "encoded" string } } +{ $description "URL-encodes a string, including all reserved characters, such as \"/\"." } ; HELP: url-quotable? { $values { "ch" "a character" } { "?" "a boolean" } } diff --git a/basis/urls/encoding/encoding.factor b/basis/urls/encoding/encoding.factor index fa882609a5..ce5bd044ac 100644 --- a/basis/urls/encoding/encoding.factor +++ b/basis/urls/encoding/encoding.factor @@ -14,6 +14,25 @@ IN: urls.encoding [ "/_-.:" member? ] } 1|| ; foldable +! see http://tools.ietf.org/html/rfc3986#section-2.2 +: gen-delim? ( ch -- ? ) + ":/?#[]@" member? ; foldable + +: sub-delim? ( ch -- ? ) + "!$&'()*+,;=" member? ; foldable + +: reserved? ( ch -- ? ) + [ gen-delim? ] [ sub-delim? ] bi or ; foldable + +! see http://tools.ietf.org/html/rfc3986#section-2.3 +: unreserved? ( ch -- ? ) + { + [ letter? ] + [ LETTER? ] + [ digit? ] + [ "-._~" member? ] + } 1|| ; foldable + [ dup url-quotable? [ , ] [ push-utf8 ] if ] each ] "" make ; +: url-encode-full ( str -- encoded ) + [ + [ dup unreserved? [ , ] [ push-utf8 ] if ] each + ] "" make ; + Date: Tue, 14 Apr 2009 10:00:09 +1000 Subject: [PATCH 10/19] couchdb in progress --- basis/http/client/client.factor | 45 +++++++++++++++++---------------- extra/couchdb/couchdb.factor | 10 ++++---- 2 files changed, 28 insertions(+), 27 deletions(-) diff --git a/basis/http/client/client.factor b/basis/http/client/client.factor index 1ba32cc61d..22d772d2b6 100644 --- a/basis/http/client/client.factor +++ b/basis/http/client/client.factor @@ -1,12 +1,12 @@ ! Copyright (C) 2005, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors assocs kernel math math.parser namespaces make +USING: accessors assocs debugger kernel math math.parser namespaces make sequences strings splitting calendar continuations accessors vectors math.order hashtables byte-arrays destructors io io.sockets io.streams.string io.files io.timeouts io.pathnames io.encodings io.encodings.string io.encodings.ascii io.encodings.utf8 io.encodings.8-bit io.encodings.binary io.crlf -io.streams.duplex fry ascii urls urls.encoding present +io.streams.duplex fry ascii urls urls.encoding present prettyprint http http.parsers http.client.post-data ; IN: http.client @@ -82,7 +82,7 @@ SYMBOL: redirects redirects get max-redirects < [ request get clone swap "location" header redirect-url - "GET" >>method swap with-http-request + "GET" >>method swap (with-http-request) ] [ too-many-redirects ] if ; inline recursive : read-chunk-size ( -- n ) @@ -105,9 +105,7 @@ SYMBOL: redirects request get url>> url-addr ascii drop 1 minutes over set-timeout ; -PRIVATE> - -: with-http-request ( request quot: ( chunk -- ) -- response ) +: (with-http-request) ( request quot: ( chunk -- ) -- response ) swap request [ [ @@ -129,23 +127,26 @@ PRIVATE> [ do-redirect ] [ nip ] if ] with-variable ; inline recursive +PRIVATE> + : ( url method -- request ) swap >>method swap >url ensure-port >>url ; inline -PRIVATE> - : success? ( code -- ? ) 200 299 between? ; -ERROR: download-failed response data ; +! ERROR: download-failed response data ; -M: download-failed error. - "HTTP request failed:" print nl - [ response>> . ] [ data>> . ] bi ; +! M: download-failed error. +! "HTTP request failed:" print nl +! [ response>> . ] [ data>> . ] bi ; +ERROR: download-failed response ; -: check-response* ( response data -- response data ) - over code>> success? [ download-failed ] unless ; +: check-response ( response -- response ) + dup code>> success? [ download-failed ] unless ; +! : check-response ( response data -- response data ) + ! over code>> success? [ download-failed ] unless ; : check-response-with-body ( response body -- response body ) [ >>body check-response ] keep ; @@ -166,17 +167,17 @@ M: download-failed error. : with-http-get ( url quot -- response ) [ ] dip with-http-request check-response ; inline -: ( url -- request ) - "DELETE" >>method ; +! : ( url -- request ) +! "DELETE" ; -: http-delete ( url -- response data ) - http-request ; +! : http-delete ( url -- response ) +! http-request ; -: ( url -- request ) - "TRACE" >>method ; +! : ( url -- request ) +! "TRACE" >>method ; -: http-trace ( url -- response data ) - http-request ; +! : http-trace ( url -- response ) +! http-request ; : download-name ( url -- name ) present file-name "?" split1 drop "/" ?tail drop ; diff --git a/extra/couchdb/couchdb.factor b/extra/couchdb/couchdb.factor index 3419244d72..c586287b2e 100644 --- a/extra/couchdb/couchdb.factor +++ b/extra/couchdb/couchdb.factor @@ -46,7 +46,7 @@ PREDICATE: file-exists-error < couchdb-error couch-request ; : couch-delete ( url -- assoc ) - couch-request ; + "DELETE" couch-request ; : response-ok ( assoc -- assoc ) "ok" over delete-at* and t assert= ; @@ -57,9 +57,9 @@ PREDICATE: file-exists-error < couchdb-error ! server TUPLE: server { host string } { port integer } { uuids vector } { uuids-to-cache integer } ; -: default-couch-host "localhost" ; -: default-couch-port 5984 ; -: default-uuids-to-cache 100 ; +: default-couch-host ( -- host ) "localhost" ; inline +: default-couch-port ( -- port ) 5984 ; inline +: default-uuids-to-cache ( -- n ) 100 ; inline : ( host port -- server ) V{ } clone default-uuids-to-cache server boa ; @@ -123,7 +123,7 @@ C: db db-url "_all_docs" append couch-get ; : ( assoc -- post-data ) - >json "application/json" ; + >json "application/json" swap >>data ; ! documents : id> ( assoc -- id ) "_id" swap at ; From 9e4adede5fb0c76925818119202b98d9d43454c2 Mon Sep 17 00:00:00 2001 From: Alex Chapman Date: Wed, 15 Apr 2009 10:52:00 +1000 Subject: [PATCH 11/19] Add and http-delete --- basis/http/client/client.factor | 33 ++++++++++----------------------- 1 file changed, 10 insertions(+), 23 deletions(-) diff --git a/basis/http/client/client.factor b/basis/http/client/client.factor index f4764ff6f2..d1997c73f9 100644 --- a/basis/http/client/client.factor +++ b/basis/http/client/client.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2005, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors assocs debugger kernel math math.parser namespaces make +USING: accessors assocs kernel math math.parser namespaces make sequences strings splitting calendar continuations accessors vectors math.order hashtables byte-arrays destructors io io.sockets io.streams.string io.files io.timeouts @@ -128,26 +128,19 @@ SYMBOL: redirects [ do-redirect ] [ nip ] if ] with-variable ; inline recursive -PRIVATE> - : ( url method -- request ) swap >>method swap >url ensure-port >>url ; inline +PRIVATE> + : success? ( code -- ? ) 200 299 between? ; -! ERROR: download-failed response data ; - -! M: download-failed error. -! "HTTP request failed:" print nl -! [ response>> . ] [ data>> . ] bi ; ERROR: download-failed response ; : check-response ( response -- response ) dup code>> success? [ download-failed ] unless ; -! : check-response ( response data -- response data ) - ! over code>> success? [ download-failed ] unless ; : check-response-with-body ( response body -- response body ) [ >>body check-response ] keep ; @@ -166,19 +159,7 @@ ERROR: download-failed response ; http-request ; : with-http-get ( url quot -- response ) - [ ] dip with-http-request check-response ; inline - -! : ( url -- request ) -! "DELETE" ; - -! : http-delete ( url -- response ) -! http-request ; - -! : ( url -- request ) -! "TRACE" >>method ; - -! : http-trace ( url -- response ) -! http-request ; + [ ] dip with-http-request ; inline : download-name ( url -- name ) present file-name "?" split1 drop "/" ?tail drop ; @@ -203,6 +184,12 @@ ERROR: download-failed response ; : http-put ( post-data url -- response data ) http-request ; +: ( url -- request ) + "DELETE" ; + +: http-delete ( url -- response data ) + http-request ; + USING: vocabs vocabs.loader ; "debugger" vocab [ "http.client.debugger" require ] when From ab6ba12a2f75a76d58079485cd6cd53b5b496417 Mon Sep 17 00:00:00 2001 From: Alex Chapman Date: Wed, 15 Apr 2009 10:54:10 +1000 Subject: [PATCH 12/19] Working minimal couchdb. Tests will fail unless couchdb is running. --- extra/couchdb/couchdb-tests.factor | 3 ++- extra/couchdb/couchdb.factor | 21 ++++++++++++--------- 2 files changed, 14 insertions(+), 10 deletions(-) diff --git a/extra/couchdb/couchdb-tests.factor b/extra/couchdb/couchdb-tests.factor index 7e38f5c2ee..d7161a14cd 100644 --- a/extra/couchdb/couchdb-tests.factor +++ b/extra/couchdb/couchdb-tests.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Alex Chapman ! See http://factorcode.org/license.txt for BSD license. -USING: assocs couchdb kernel namespaces sequences strings tools.test ; +USING: accessors assocs couchdb kernel namespaces sequences strings tools.test ; IN: couchdb.tests ! You must have a CouchDB server (currently only the version from svn will @@ -16,6 +16,7 @@ IN: couchdb.tests [ ] [ couch get ensure-db ] unit-test [ 0 ] [ couch get db-info "doc_count" swap at ] unit-test [ ] [ couch get compact-db ] unit-test + [ t ] [ couch get server>> next-uuid string? ] unit-test [ ] [ H{ { "Subject" "I like Planktion" } { "Tags" { "plankton" "baseball" "decisions" } } diff --git a/extra/couchdb/couchdb.factor b/extra/couchdb/couchdb.factor index c586287b2e..da71acb074 100644 --- a/extra/couchdb/couchdb.factor +++ b/extra/couchdb/couchdb.factor @@ -1,6 +1,9 @@ -! Copyright (C) 2008 Alex Chapman +! Copyright (C) 2008, 2009 Alex Chapman ! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays assocs continuations debugger hashtables http http.client io json.reader json.writer kernel make math math.parser namespaces sequences strings urls urls.encoding vectors ; +USING: accessors arrays assocs continuations debugger hashtables http +http.client io io.encodings.string io.encodings.utf8 json.reader +json.writer kernel make math math.parser namespaces sequences strings +urls urls.encoding vectors ; IN: couchdb ! NOTE: This code only works with the latest couchdb (0.9.*), because old @@ -27,7 +30,7 @@ PREDICATE: file-exists-error < couchdb-error : couch-http-request ( request -- data ) [ http-request ] [ dup download-failed? [ - data>> json> throw + response>> body>> json> throw ] [ rethrow ] if @@ -46,7 +49,7 @@ PREDICATE: file-exists-error < couchdb-error couch-request ; : couch-delete ( url -- assoc ) - "DELETE" couch-request ; + couch-request ; : response-ok ( assoc -- assoc ) "ok" over delete-at* and t assert= ; @@ -79,11 +82,11 @@ TUPLE: server { host string } { port integer } { uuids vector } { uuids-to-cache : uuids-url ( server -- url ) [ dup server-url % "_uuids?count=" % uuids-to-cache>> number>string % ] "" make ; -: uuids-post ( server -- uuids ) - uuids-url f swap couch-post "uuids" swap at >vector ; +: uuids-get ( server -- uuids ) + uuids-url couch-get "uuids" swap at >vector ; : get-uuids ( server -- server ) - dup uuids-post [ nip ] curry change-uuids ; + dup uuids-get [ nip ] curry change-uuids ; : ensure-uuids ( server -- server ) dup uuids>> empty? [ get-uuids ] when ; @@ -123,7 +126,7 @@ C: db db-url "_all_docs" append couch-get ; : ( assoc -- post-data ) - >json "application/json" swap >>data ; + >json utf8 encode "application/json" swap >>data ; ! documents : id> ( assoc -- id ) "_id" swap at ; @@ -189,7 +192,7 @@ C: db ! construct-attachment H{ } clone ! TODO: -! - startkey, count, descending, etc. +! - startkey, limit, descending, etc. ! - loading specific revisions ! - views ! - attachments From c78d3dda3d406e5588f8c9175862ae4786178657 Mon Sep 17 00:00:00 2001 From: Alex Chapman Date: Wed, 15 Apr 2009 15:42:01 +1000 Subject: [PATCH 13/19] Merging hats into refs to generalise refs --- basis/refs/authors.txt | 1 + basis/refs/refs-docs.factor | 107 +++++++++++++++++++++++++++++++---- basis/refs/refs-tests.factor | 85 +++++++++++++++++++++++++++- basis/refs/refs.factor | 77 +++++++++++++++++++++---- extra/hats/authors.txt | 1 - extra/hats/hats-tests.factor | 87 ---------------------------- extra/hats/hats.factor | 57 ------------------- extra/hats/summary.txt | 1 - 8 files changed, 246 insertions(+), 170 deletions(-) delete mode 100644 extra/hats/authors.txt delete mode 100644 extra/hats/hats-tests.factor delete mode 100644 extra/hats/hats.factor delete mode 100644 extra/hats/summary.txt diff --git a/basis/refs/authors.txt b/basis/refs/authors.txt index 1901f27a24..22d592c1dd 100755 --- a/basis/refs/authors.txt +++ b/basis/refs/authors.txt @@ -1 +1,2 @@ Slava Pestov +Alex Chapman diff --git a/basis/refs/refs-docs.factor b/basis/refs/refs-docs.factor index a219f0ba8b..9c10641c4c 100644 --- a/basis/refs/refs-docs.factor +++ b/basis/refs/refs-docs.factor @@ -1,38 +1,90 @@ -! Copyright (C) 2007 Slava Pestov +! Copyright (C) 2007 Slava Pestov, 2009 Alex Chapman ! See http://factorcode.org/license.txt for BSD license. -USING: help.markup help.syntax kernel ; +USING: boxes help.markup help.syntax kernel math namespaces ; IN: refs -ARTICLE: "refs" "References to assoc entries" -"A " { $emphasis "reference" } " is an object encapsulating an assoc and a key; the reference then refers to either the key itself, or the value associated to the key. References can be read, written, and deleted. References are defined in the " { $vocab-link "refs" } " vocabulary." +ARTICLE: "refs" "References" +"References provide a uniform way of accessing and changing values. Some examples of referenced values are variables, tuple slots, and keys or values of assocs. References can be read, written, and deleted. References are defined in the " { $vocab-link "refs" } " vocabulary, and new reference types can be made by implementing the " { $link "refs-protocol" } "." { $subsection get-ref } { $subsection set-ref } +{ $subsection set-ref* } { $subsection delete-ref } -"References to keys:" +"References to objects:" +{ $subsection obj-ref } +{ $subsection } +"References to assoc keys:" { $subsection key-ref } { $subsection } -"References to values:" +"References to assoc values:" { $subsection value-ref } { $subsection } +"References to variables:" +{ $subsection var-ref } +{ $subsection } +{ $subsection global-var-ref } +{ $subsection } +"References to tuple slots:" +{ $subsection slot-ref } +{ $subsection } +"Using boxes as references:" +{ $subsection "box-refs" } "References are used by the UI inspector." ; ABOUT: "refs" +ARTICLE: "refs-protocol" "Reference Protocol" +"To use a class of objects as references you must implement the reference protocol for that class, and mark your class as an instance of the " { $link ref } " mixin class. All references must implement these two words:" +{ $subsection get-ref } +{ $subsection set-ref } +"References may also implement:" +{ $subsection delete-ref } ; + +ARTICLE: "box-refs" "Using Boxes as References" +"Boxes are elements of the " { $link ref } " mixin class, so any box may be used as a reference. Bear in mind that boxes will still throw an error if you call " { $link get-ref } " on an empty box." ; + HELP: ref -{ $class-description "A class whose instances identify a key or value location in an associative structure. Instances of this clas are never used directly; only instances of " { $link key-ref } " and " { $link value-ref } " should be created." } ; +{ $class-description "A mixin class whose instances encapsulate a value which can be read, written, and deleted. Instantiable members of this class include:" { $link obj-ref } ", " { $link var-ref } ", " { $link global-var-ref } ", " { $link slot-ref } ", " { $link box } ", " { $link key-ref } ", and " { $link value-ref } "." } ; HELP: delete-ref { $values { "ref" ref } } -{ $description "Deletes the association entry pointed at by this reference." } ; +{ $description "Deletes the value pointed to by this reference. In most references this simply sets the value to f, but in some cases it is more destructive, such as in " { $link value-ref } " and " { $link key-ref } ", where it actually deletes the entry from the underlying assoc." } ; HELP: get-ref { $values { "ref" ref } { "obj" object } } -{ $description "Outputs the key or the value pointed at by this reference." } ; +{ $description "Outputs the value pointed at by this reference." } ; HELP: set-ref { $values { "obj" object } { "ref" ref } } -{ $description "Stores a new key or value at by this reference." } ; +{ $description "Stores a new value at this reference." } ; +HELP: obj-ref +{ $class-description "Instances of this class contain a value which can be changed using the " { $link "refs-protocol" } ". New object references are created by calling " { $link } "." } ; + +HELP: +{ $values { "obj" object } { "obj-ref" obj-ref } } +{ $description "Creates a reference which contains the value it references." } ; + +HELP: var-ref +{ $class-description "Instances of this class reference a variable as defined by the " { $vocab-link "namespaces" } " vocabulary. New variable references are created by calling " { $link } "." } ; + +HELP: +{ $values { "var" object } { "var-ref" var-ref } } +{ $description "Creates a reference to the given variable. Note that this reference behaves just like any variable when it comes to dynamic scope. For example, if you use " { $link set-ref } " in an inner scope and then leave that scope, then calling " { $link get-ref } " may not return the expected value. If this is not what you want, try using an " { $link obj-ref } " instead." } ; + +HELP: global-var-ref +{ $class-description "Instances of this class reference a global variable. New global references are created by calling " { $link } "." } ; + +HELP: +{ $values { "var" object } { "global-var-ref" global-var-ref } } +{ $description "Creates a reference to a global variable." } ; + +HELP: slot-ref +{ $class-description "Instances of this class identify a particular slot of a particular instance of a tuple. New slot references are created by calling " { $link } "." } ; + +HELP: +{ $values { "tuple" tuple } { "slot" integer } { "slot-ref" slot-ref } } +{ $description "Creates a reference to the value in a particular slot of the given tuple. The slot must be given as an integer, where the first user-defined slot is number 2. This is mostly just a proof of concept until we have a way of generating this slot number from a slot name." } ; + HELP: key-ref { $class-description "Instances of this class identify a key in an associative structure. New key references are created by calling " { $link } "." } ; @@ -47,6 +99,37 @@ HELP: { $values { "assoc" "an assoc" } { "key" object } { "value-ref" value-ref } } { $description "Creates a reference to the value associated with " { $snippet "key" } " in " { $snippet "assoc" } "." } ; -{ get-ref set-ref delete-ref } related-words +{ get-ref set-ref delete-ref set-ref* } related-words + +{ } related-words -{ } related-words +HELP: set-ref* +{ $values { "ref" ref } { "obj" object } } +{ $description "Just like " { $link set-ref } ", but leave the ref on the stack." } ; + +HELP: ref-on +{ $values { "ref" ref } } +{ $description "Sets the value of the ref to t." } ; + +HELP: ref-off +{ $values { "ref" ref } } +{ $description "Sets the value of the ref to f." } ; + +HELP: ref-inc +{ $values { "ref" ref } } +{ $description "Increment the value of the ref by 1." } ; + +HELP: ref-dec +{ $values { "ref" ref } } +{ $description "Decrement the value of the ref by 1." } ; + +HELP: take +{ $values { "ref" ref } { "obj" object } } +{ $description "Retrieve the value of the ref and then delete it, returning the value." } ; + +{ ref-on ref-off ref-inc ref-dec take } related-words +{ take delete-ref } related-words +{ on ref-on } related-words +{ off ref-off } related-words +{ inc ref-inc } related-words +{ dec ref-dec } related-words diff --git a/basis/refs/refs-tests.factor b/basis/refs/refs-tests.factor index 1d921854e9..bf58aaf43d 100644 --- a/basis/refs/refs-tests.factor +++ b/basis/refs/refs-tests.factor @@ -1,5 +1,7 @@ -USING: refs tools.test kernel ; +USING: boxes kernel namespaces refs tools.test ; +IN: refs.tests +! assoc-refs [ 3 ] [ H{ { "a" 3 } } "a" get-ref ] unit-test @@ -20,3 +22,84 @@ USING: refs tools.test kernel ; set-ref ] keep ] unit-test + +SYMBOLS: lion giraffe elephant rabbit ; + +! obj-refs +[ rabbit ] [ rabbit get-ref ] unit-test +[ rabbit ] [ f rabbit set-ref* get-ref ] unit-test +[ rabbit ] [ rabbit take ] unit-test +[ rabbit f ] [ rabbit [ take ] keep get-ref ] unit-test +[ lion ] [ rabbit dup [ drop lion ] change-ref get-ref ] unit-test + +! var-refs +[ giraffe ] [ [ giraffe rabbit set rabbit get-ref ] with-scope ] unit-test + +[ rabbit ] +[ + [ + lion rabbit set [ + rabbit rabbit set rabbit get-ref + ] with-scope + ] with-scope +] unit-test + +[ rabbit ] [ + rabbit + [ + lion rabbit set [ + rabbit rabbit set get-ref + ] with-scope + ] with-scope +] unit-test + +[ elephant ] [ + rabbit + [ + elephant rabbit set [ + rabbit rabbit set + ] with-scope + get-ref + ] with-scope +] unit-test + +[ rabbit ] [ + rabbit + [ + elephant set-ref* [ + rabbit set-ref* get-ref + ] with-scope + ] with-scope +] unit-test + +[ elephant ] [ + rabbit + [ + elephant set-ref* [ + rabbit set-ref* + ] with-scope + get-ref + ] with-scope +] unit-test + +! Top Hats +[ lion ] [ lion rabbit set-global rabbit get-ref ] unit-test +[ giraffe ] [ rabbit giraffe set-ref* get-ref ] unit-test + +! Tuple refs +TUPLE: foo bar ; +C: foo + +: test-tuple ( -- tuple ) + rabbit ; + +: test-slot-ref ( -- slot-ref ) + test-tuple 2 ; ! hack! + +[ rabbit ] [ test-slot-ref get-ref ] unit-test +[ lion ] [ test-slot-ref lion set-ref* get-ref ] unit-test + +! Boxes as refs +[ rabbit ] [ rabbit set-ref* get-ref ] unit-test +[ rabbit set-ref* lion set-ref* ] must-fail +[ get-ref ] must-fail diff --git a/basis/refs/refs.factor b/basis/refs/refs.factor index 0164a1ea57..668cdd65c3 100644 --- a/basis/refs/refs.factor +++ b/basis/refs/refs.factor @@ -1,22 +1,77 @@ -! Copyright (C) 2007, 2008 Slava Pestov +! Copyright (C) 2007, 2008 Slava Pestov, 2009 Alex Chapman ! See http://factorcode.org/license.txt for BSD license. -USING: classes.tuple kernel assocs accessors ; +USING: kernel assocs accessors boxes math namespaces ; IN: refs -TUPLE: ref assoc key ; +MIXIN: ref -: >ref< ( ref -- key value ) [ key>> ] [ assoc>> ] bi ; inline - -: delete-ref ( ref -- ) >ref< delete-at ; GENERIC: get-ref ( ref -- obj ) GENERIC: set-ref ( obj ref -- ) +GENERIC: delete-ref ( ref -- ) -TUPLE: key-ref < ref ; +! works like >>slot words +: set-ref* ( ref obj -- ref ) over set-ref ; + +! very similar to change, on, off, +@, inc, and dec from namespaces +: change-ref ( ref quot -- ) + [ [ get-ref ] keep ] dip dip set-ref ; inline +: ref-on ( ref -- ) t swap set-ref ; +: ref-off ( ref -- ) f swap set-ref ; +: ref-+@ ( n ref -- ) [ 0 or + ] change-ref ; +: ref-inc ( ref -- ) 1 swap ref-+@ ; +: ref-dec ( ref -- ) -1 swap ref-+@ ; + +: take ( ref -- obj ) + dup get-ref swap delete-ref ; + +! delete-ref defaults to setting ref to f +M: ref delete-ref ref-off ; + +TUPLE: obj-ref obj ; +C: obj-ref +M: obj-ref get-ref obj>> ; +M: obj-ref set-ref (>>obj) ; +INSTANCE: obj-ref ref + +TUPLE: var-ref var ; +C: var-ref +M: var-ref get-ref var>> get ; +M: var-ref set-ref var>> set ; +INSTANCE: var-ref ref + +TUPLE: global-var-ref var ; +C: global-var-ref +M: global-var-ref get-ref var>> get-global ; +M: global-var-ref set-ref var>> set-global ; +INSTANCE: global-var-ref ref + +USE: slots.private +TUPLE: slot-ref tuple slot ; +C: slot-ref +: >slot-ref< ( slot-ref -- tuple slot ) [ tuple>> ] [ slot>> ] bi ; inline +M: slot-ref get-ref >slot-ref< slot ; +M: slot-ref set-ref >slot-ref< set-slot ; +INSTANCE: slot-ref ref + +M: box get-ref box> ; +M: box set-ref >box ; +M: box delete-ref box> drop ; +INSTANCE: box ref + +TUPLE: assoc-ref assoc key ; + +: >assoc-ref< ( assoc-ref -- key value ) [ key>> ] [ assoc>> ] bi ; inline + +M: assoc-ref delete-ref ( assoc-ref -- ) >assoc-ref< delete-at ; + +TUPLE: key-ref < assoc-ref ; C: key-ref M: key-ref get-ref key>> ; -M: key-ref set-ref >ref< rename-at ; +M: key-ref set-ref >assoc-ref< rename-at ; +INSTANCE: key-ref ref -TUPLE: value-ref < ref ; +TUPLE: value-ref < assoc-ref ; C: value-ref -M: value-ref get-ref >ref< at ; -M: value-ref set-ref >ref< set-at ; +M: value-ref get-ref >assoc-ref< at ; +M: value-ref set-ref >assoc-ref< set-at ; +INSTANCE: value-ref ref diff --git a/extra/hats/authors.txt b/extra/hats/authors.txt deleted file mode 100644 index e9c193bac7..0000000000 --- a/extra/hats/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Alex Chapman diff --git a/extra/hats/hats-tests.factor b/extra/hats/hats-tests.factor deleted file mode 100644 index ebb61a0830..0000000000 --- a/extra/hats/hats-tests.factor +++ /dev/null @@ -1,87 +0,0 @@ -! Copyright (C) 2008 Alex Chapman. -! See http://factorcode.org/license.txt for BSD license. -USING: boxes hats kernel namespaces symbols tools.test ; -IN: hats.tests - -SYMBOLS: lion giraffe elephant rabbit ; - -! caps -[ rabbit ] [ rabbit out ] unit-test -[ rabbit ] [ f rabbit in out ] unit-test -[ rabbit ] [ rabbit take ] unit-test -[ f ] [ rabbit empty-hat out ] unit-test -[ rabbit f ] [ rabbit [ take ] keep out ] unit-test -[ rabbit t ] [ rabbit [ take ] keep empty-hat? ] unit-test -[ lion ] [ rabbit [ drop lion ] change-hat out ] unit-test - -! bowlers -[ giraffe ] [ [ giraffe rabbit set rabbit out ] with-scope ] unit-test - -[ rabbit ] -[ - [ - lion rabbit set [ - rabbit rabbit set rabbit out - ] with-scope - ] with-scope -] unit-test - -[ rabbit ] [ - rabbit - [ - lion rabbit set [ - rabbit rabbit set out - ] with-scope - ] with-scope -] unit-test - -[ elephant ] [ - rabbit - [ - elephant rabbit set [ - rabbit rabbit set - ] with-scope - out - ] with-scope -] unit-test - -[ rabbit ] [ - rabbit - [ - elephant in [ - rabbit in out - ] with-scope - ] with-scope -] unit-test - -[ elephant ] [ - rabbit - [ - elephant in [ - rabbit in - ] with-scope - out - ] with-scope -] unit-test - -! Top Hats -[ lion ] [ lion rabbit set-global rabbit out ] unit-test -[ giraffe ] [ rabbit giraffe in out ] unit-test - -! Tuple hats -TUPLE: foo bar ; -C: foo - -: test-tuple ( -- tuple ) - rabbit ; - -: test-slot-hat ( -- slot-hat ) - test-tuple 2 ; ! hack! - -[ rabbit ] [ test-slot-hat out ] unit-test -[ lion ] [ test-slot-hat lion in out ] unit-test - -! Boxes as hats -[ rabbit ] [ rabbit in out ] unit-test -[ rabbit in lion in ] must-fail -[ out ] must-fail diff --git a/extra/hats/hats.factor b/extra/hats/hats.factor deleted file mode 100644 index 113705bd11..0000000000 --- a/extra/hats/hats.factor +++ /dev/null @@ -1,57 +0,0 @@ -! Copyright (C) 2008 Alex Chapman. -! See http://factorcode.org/license.txt for BSD license. -USING: accessors boxes kernel namespaces ; -IN: hats - -! Bullwinkle: Hey Rocky, watch me pull a rabbit out of my hat! -! Rocky: But that trick never works! -! Bullwinkle: This time for sure! - -! hat protocol -MIXIN: hat - -GENERIC: out ( hat -- object ) -GENERIC: (in) ( object hat -- ) - -: in ( hat object -- hat ) over (in) ; inline -: empty-hat? ( hat -- ? ) out not ; inline -: empty-hat ( hat -- hat ) f in ; inline -: take ( hat -- object ) dup out f rot (in) ; inline -: change-hat ( hat quot -- hat ) - over >r >r out r> call r> swap in ; inline - -! caps (the simplest of hats) -TUPLE: cap object ; -C: cap -M: cap out ( cap -- object ) object>> ; -M: cap (in) ( object cap -- ) (>>object) ; -INSTANCE: cap hat - -! bowlers (dynamic variable hats) -TUPLE: bowler variable ; -C: bowler -M: bowler out ( bowler -- object ) variable>> get ; -M: bowler (in) ( object bowler -- ) variable>> set ; -INSTANCE: bowler hat - -! Top Hats (global variable hats) -TUPLE: top-hat variable ; -C: top-hat -M: top-hat out ( top-hat -- object ) variable>> get-global ; -M: top-hat (in) ( object top-hat -- ) variable>> set-global ; -INSTANCE: top-hat hat - -USE: slots.private -! Slot hats -TUPLE: slot-hat tuple slot ; -C: slot-hat -: >slot-hat< ( slot-hat -- tuple slot ) [ tuple>> ] [ slot>> ] bi ; inline -M: slot-hat out ( slot-hat -- object ) >slot-hat< slot ; -M: slot-hat (in) ( object slot-hat -- ) >slot-hat< set-slot ; -INSTANCE: slot-hat hat - -! Put a box on your head -M: box out ( box -- object ) box> ; -M: box (in) ( object box -- ) >box ; -INSTANCE: box hat - diff --git a/extra/hats/summary.txt b/extra/hats/summary.txt deleted file mode 100644 index 9590639922..0000000000 --- a/extra/hats/summary.txt +++ /dev/null @@ -1 +0,0 @@ -A protocol for getting and setting From d34539bca198232b1bbc8a9eb4bc097d3c4b0503 Mon Sep 17 00:00:00 2001 From: Alex Chapman Date: Wed, 15 Apr 2009 19:59:52 +1000 Subject: [PATCH 14/19] Retrieving jamshred from repository history --- unmaintained/jamshred/authors.txt | 1 + unmaintained/jamshred/deploy.factor | 12 ++ unmaintained/jamshred/game/authors.txt | 1 + unmaintained/jamshred/game/game.factor | 40 +++++ unmaintained/jamshred/gl/authors.txt | 1 + unmaintained/jamshred/gl/gl.factor | 99 +++++++++++ unmaintained/jamshred/jamshred.factor | 94 ++++++++++ unmaintained/jamshred/log/log.factor | 10 ++ unmaintained/jamshred/oint/authors.txt | 1 + unmaintained/jamshred/oint/oint-tests.factor | 8 + unmaintained/jamshred/oint/oint.factor | 73 ++++++++ unmaintained/jamshred/player/authors.txt | 1 + unmaintained/jamshred/player/player.factor | 137 ++++++++++++++ unmaintained/jamshred/sound/sound.factor | 15 ++ unmaintained/jamshred/summary.txt | 1 + unmaintained/jamshred/tags.txt | 2 + unmaintained/jamshred/tunnel/authors.txt | 1 + .../jamshred/tunnel/tunnel-tests.factor | 45 +++++ unmaintained/jamshred/tunnel/tunnel.factor | 167 ++++++++++++++++++ 19 files changed, 709 insertions(+) create mode 100644 unmaintained/jamshred/authors.txt create mode 100644 unmaintained/jamshred/deploy.factor create mode 100644 unmaintained/jamshred/game/authors.txt create mode 100644 unmaintained/jamshred/game/game.factor create mode 100644 unmaintained/jamshred/gl/authors.txt create mode 100644 unmaintained/jamshred/gl/gl.factor create mode 100644 unmaintained/jamshred/jamshred.factor create mode 100644 unmaintained/jamshred/log/log.factor create mode 100644 unmaintained/jamshred/oint/authors.txt create mode 100644 unmaintained/jamshred/oint/oint-tests.factor create mode 100644 unmaintained/jamshred/oint/oint.factor create mode 100644 unmaintained/jamshred/player/authors.txt create mode 100644 unmaintained/jamshred/player/player.factor create mode 100644 unmaintained/jamshred/sound/sound.factor create mode 100644 unmaintained/jamshred/summary.txt create mode 100644 unmaintained/jamshred/tags.txt create mode 100644 unmaintained/jamshred/tunnel/authors.txt create mode 100644 unmaintained/jamshred/tunnel/tunnel-tests.factor create mode 100644 unmaintained/jamshred/tunnel/tunnel.factor diff --git a/unmaintained/jamshred/authors.txt b/unmaintained/jamshred/authors.txt new file mode 100644 index 0000000000..e9c193bac7 --- /dev/null +++ b/unmaintained/jamshred/authors.txt @@ -0,0 +1 @@ +Alex Chapman diff --git a/unmaintained/jamshred/deploy.factor b/unmaintained/jamshred/deploy.factor new file mode 100644 index 0000000000..9a18cf1f9b --- /dev/null +++ b/unmaintained/jamshred/deploy.factor @@ -0,0 +1,12 @@ +USING: tools.deploy.config ; +V{ + { deploy-ui? t } + { deploy-io 1 } + { deploy-reflection 1 } + { deploy-compiler? t } + { deploy-math? t } + { deploy-word-props? f } + { deploy-c-types? f } + { "stop-after-last-window?" t } + { deploy-name "Jamshred" } +} diff --git a/unmaintained/jamshred/game/authors.txt b/unmaintained/jamshred/game/authors.txt new file mode 100644 index 0000000000..e9c193bac7 --- /dev/null +++ b/unmaintained/jamshred/game/authors.txt @@ -0,0 +1 @@ +Alex Chapman diff --git a/unmaintained/jamshred/game/game.factor b/unmaintained/jamshred/game/game.factor new file mode 100644 index 0000000000..9cb5bc7c3a --- /dev/null +++ b/unmaintained/jamshred/game/game.factor @@ -0,0 +1,40 @@ +! Copyright (C) 2007, 2008 Alex Chapman +! See http://factorcode.org/license.txt for BSD license. +USING: accessors kernel opengl arrays sequences jamshred.log jamshred.player jamshred.sound jamshred.tunnel math math.constants math.vectors ; +IN: jamshred.game + +TUPLE: jamshred sounds tunnel players running quit ; + +: ( -- jamshred ) + "Player 1" pick + 2dup swap play-in-tunnel 1array f f jamshred boa ; + +: jamshred-player ( jamshred -- player ) + ! TODO: support more than one player + players>> first ; + +: jamshred-update ( jamshred -- ) + dup running>> [ + jamshred-player update-player + ] [ drop ] if ; + +: toggle-running ( jamshred -- ) + dup running>> [ + f >>running drop + ] [ + [ jamshred-player moved ] + [ t >>running drop ] bi + ] if ; + +: mouse-moved ( x-radians y-radians jamshred -- ) + jamshred-player -rot turn-player ; + +: units-per-full-roll ( -- n ) 50 ; + +: jamshred-roll ( jamshred n -- ) + [ jamshred-player ] dip 2 pi * * units-per-full-roll / roll-player ; + +: mouse-scroll-x ( jamshred x -- ) jamshred-roll ; + +: mouse-scroll-y ( jamshred y -- ) + neg swap jamshred-player change-player-speed ; diff --git a/unmaintained/jamshred/gl/authors.txt b/unmaintained/jamshred/gl/authors.txt new file mode 100644 index 0000000000..e9c193bac7 --- /dev/null +++ b/unmaintained/jamshred/gl/authors.txt @@ -0,0 +1 @@ +Alex Chapman diff --git a/unmaintained/jamshred/gl/gl.factor b/unmaintained/jamshred/gl/gl.factor new file mode 100644 index 0000000000..b78e7de88e --- /dev/null +++ b/unmaintained/jamshred/gl/gl.factor @@ -0,0 +1,99 @@ +! Copyright (C) 2007, 2008 Alex Chapman +! See http://factorcode.org/license.txt for BSD license. +USING: accessors alien.c-types jamshred.game jamshred.oint +jamshred.player jamshred.tunnel kernel math math.constants +math.functions math.vectors opengl opengl.gl opengl.glu +opengl.demo-support sequences specialized-arrays.float ; +IN: jamshred.gl + +: min-vertices 6 ; inline +: max-vertices 32 ; inline + +: n-vertices ( -- n ) 32 ; inline + +! render enough of the tunnel that it looks continuous +: n-segments-ahead ( -- n ) 60 ; inline +: n-segments-behind ( -- n ) 40 ; inline + +: wall-drawing-offset ( -- n ) + #! so that we can't see through the wall, we draw it a bit further away + 0.15 ; + +: wall-drawing-radius ( segment -- r ) + radius>> wall-drawing-offset + ; + +: wall-up ( segment -- v ) + [ wall-drawing-radius ] [ up>> ] bi n*v ; + +: wall-left ( segment -- v ) + [ wall-drawing-radius ] [ left>> ] bi n*v ; + +: segment-vertex ( theta segment -- vertex ) + [ + [ wall-up swap sin v*n ] [ wall-left swap cos v*n ] 2bi v+ + ] [ + location>> v+ + ] bi ; + +: segment-vertex-normal ( vertex segment -- normal ) + location>> swap v- normalize ; + +: segment-vertex-and-normal ( segment theta -- vertex normal ) + swap [ segment-vertex ] keep dupd segment-vertex-normal ; + +: equally-spaced-radians ( n -- seq ) + #! return a sequence of n numbers between 0 and 2pi + dup [ / pi 2 * * ] curry map ; + +: draw-segment-vertex ( segment theta -- ) + over color>> gl-color segment-vertex-and-normal + gl-normal gl-vertex ; + +: draw-vertex-pair ( theta next-segment segment -- ) + rot tuck draw-segment-vertex draw-segment-vertex ; + +: draw-segment ( next-segment segment -- ) + GL_QUAD_STRIP [ + [ draw-vertex-pair ] 2curry + n-vertices equally-spaced-radians F{ 0.0 } append swap each + ] do-state ; + +: draw-segments ( segments -- ) + 1 over length pick subseq swap [ draw-segment ] 2each ; + +: segments-to-render ( player -- segments ) + dup nearest-segment>> number>> dup n-segments-behind - + swap n-segments-ahead + rot tunnel>> sub-tunnel ; + +: draw-tunnel ( player -- ) + segments-to-render draw-segments ; + +: init-graphics ( width height -- ) + GL_DEPTH_TEST glEnable + GL_SCISSOR_TEST glDisable + 1.0 glClearDepth + 0.0 0.0 0.0 0.0 glClearColor + GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT bitor glClear + GL_PROJECTION glMatrixMode glLoadIdentity + dup 0 = [ 2drop ] [ / >float 45.0 swap 0.1 100.0 gluPerspective ] if + GL_MODELVIEW glMatrixMode glLoadIdentity + GL_LEQUAL glDepthFunc + GL_LIGHTING glEnable + GL_LIGHT0 glEnable + GL_FOG glEnable + GL_FOG_DENSITY 0.09 glFogf + GL_FRONT GL_AMBIENT_AND_DIFFUSE glColorMaterial + GL_COLOR_MATERIAL glEnable + GL_LIGHT0 GL_POSITION float-array{ 0.0 0.0 0.0 1.0 } underlying>> glLightfv + GL_LIGHT0 GL_AMBIENT float-array{ 0.2 0.2 0.2 1.0 } underlying>> glLightfv + GL_LIGHT0 GL_DIFFUSE float-array{ 1.0 1.0 1.0 1.0 } underlying>> glLightfv + GL_LIGHT0 GL_SPECULAR float-array{ 1.0 1.0 1.0 1.0 } underlying>> glLightfv ; + +: player-view ( player -- ) + [ location>> ] + [ [ location>> ] [ forward>> ] bi v+ ] + [ up>> ] tri gl-look-at ; + +: draw-jamshred ( jamshred width height -- ) + init-graphics jamshred-player [ player-view ] [ draw-tunnel ] bi ; + diff --git a/unmaintained/jamshred/jamshred.factor b/unmaintained/jamshred/jamshred.factor new file mode 100644 index 0000000000..d0b74417d1 --- /dev/null +++ b/unmaintained/jamshred/jamshred.factor @@ -0,0 +1,94 @@ +! Copyright (C) 2007, 2008 Alex Chapman +! See http://factorcode.org/license.txt for BSD license. +USING: accessors arrays calendar jamshred.game jamshred.gl jamshred.player jamshred.log kernel math math.constants math.geometry.rect math.vectors namespaces sequences threads ui ui.backend ui.gadgets ui.gadgets.worlds ui.gestures ui.render ; +IN: jamshred + +TUPLE: jamshred-gadget < gadget { jamshred jamshred } last-hand-loc ; + +: ( jamshred -- gadget ) + jamshred-gadget new-gadget swap >>jamshred ; + +: default-width ( -- x ) 800 ; +: default-height ( -- y ) 600 ; + +M: jamshred-gadget pref-dim* + drop default-width default-height 2array ; + +M: jamshred-gadget draw-gadget* ( gadget -- ) + [ jamshred>> ] [ rect-dim first2 draw-jamshred ] bi ; + +: jamshred-loop ( gadget -- ) + dup jamshred>> quit>> [ + drop + ] [ + [ jamshred>> jamshred-update ] + [ relayout-1 ] + [ 10 milliseconds sleep yield jamshred-loop ] tri + ] if ; + +: fullscreen ( gadget -- ) + find-world t swap set-fullscreen* ; + +: no-fullscreen ( gadget -- ) + find-world f swap set-fullscreen* ; + +: toggle-fullscreen ( world -- ) + [ fullscreen? not ] keep set-fullscreen* ; + +M: jamshred-gadget graft* ( gadget -- ) + [ jamshred-loop ] curry in-thread ; + +M: jamshred-gadget ungraft* ( gadget -- ) + jamshred>> t swap (>>quit) ; + +: jamshred-restart ( jamshred-gadget -- ) + >>jamshred drop ; + +: pix>radians ( n m -- theta ) + / pi 4 * * ; ! 2 / / pi 2 * * ; + +: x>radians ( x gadget -- theta ) + #! translate motion of x pixels to an angle + rect-dim first pix>radians neg ; + +: y>radians ( y gadget -- theta ) + #! translate motion of y pixels to an angle + rect-dim second pix>radians ; + +: (handle-mouse-motion) ( jamshred-gadget mouse-motion -- ) + over jamshred>> >r + [ first swap x>radians ] 2keep second swap y>radians + r> mouse-moved ; + +: handle-mouse-motion ( jamshred-gadget -- ) + hand-loc get [ + over last-hand-loc>> [ + v- (handle-mouse-motion) + ] [ 2drop ] if* + ] 2keep >>last-hand-loc drop ; + +: handle-mouse-scroll ( jamshred-gadget -- ) + jamshred>> scroll-direction get + [ first mouse-scroll-x ] + [ second mouse-scroll-y ] 2bi ; + +: quit ( gadget -- ) + [ no-fullscreen ] [ close-window ] bi ; + +jamshred-gadget H{ + { T{ key-down f f "r" } [ jamshred-restart ] } + { T{ key-down f f " " } [ jamshred>> toggle-running ] } + { T{ key-down f f "f" } [ find-world toggle-fullscreen ] } + { T{ key-down f f "UP" } [ jamshred>> jamshred-player 1 swap change-player-speed ] } + { T{ key-down f f "DOWN" } [ jamshred>> jamshred-player -1 swap change-player-speed ] } + { T{ key-down f f "LEFT" } [ jamshred>> 1 jamshred-roll ] } + { T{ key-down f f "RIGHT" } [ jamshred>> -1 jamshred-roll ] } + { T{ key-down f f "q" } [ quit ] } + { T{ motion } [ handle-mouse-motion ] } + { T{ mouse-scroll } [ handle-mouse-scroll ] } +} set-gestures + +: jamshred-window ( -- gadget ) + [ dup "Jamshred" open-window ] with-ui ; + +MAIN: jamshred-window diff --git a/unmaintained/jamshred/log/log.factor b/unmaintained/jamshred/log/log.factor new file mode 100644 index 0000000000..33498d8a2e --- /dev/null +++ b/unmaintained/jamshred/log/log.factor @@ -0,0 +1,10 @@ +USING: kernel logging ; +IN: jamshred.log + +LOG: (jamshred-log) DEBUG + +: with-jamshred-log ( quot -- ) + "jamshred" swap with-logging ; + +: jamshred-log ( message -- ) + [ (jamshred-log) ] with-jamshred-log ; ! ugly... diff --git a/unmaintained/jamshred/oint/authors.txt b/unmaintained/jamshred/oint/authors.txt new file mode 100644 index 0000000000..e9c193bac7 --- /dev/null +++ b/unmaintained/jamshred/oint/authors.txt @@ -0,0 +1 @@ +Alex Chapman diff --git a/unmaintained/jamshred/oint/oint-tests.factor b/unmaintained/jamshred/oint/oint-tests.factor new file mode 100644 index 0000000000..401935fd01 --- /dev/null +++ b/unmaintained/jamshred/oint/oint-tests.factor @@ -0,0 +1,8 @@ +USING: jamshred.oint tools.test ; +IN: jamshred.oint-tests + +[ { 0 -1 -1 } ] [ { 0 1 -1 } { 0 -1 0 } reflect ] unit-test +[ { 0 1 0 } ] [ { 1 1 0 } { 1 0 0 } proj-perp ] unit-test +[ { 1 0 0 } ] [ { 1 1 0 } { 0 1 0 } proj-perp ] unit-test +[ { 1/2 -1/2 0 } ] [ { 1 0 0 } { 1 1 0 } proj-perp ] unit-test +[ { -1/2 1/2 0 } ] [ { 0 1 0 } { 1 1 0 } proj-perp ] unit-test diff --git a/unmaintained/jamshred/oint/oint.factor b/unmaintained/jamshred/oint/oint.factor new file mode 100644 index 0000000000..808e92a1f9 --- /dev/null +++ b/unmaintained/jamshred/oint/oint.factor @@ -0,0 +1,73 @@ +! Copyright (C) 2007, 2008 Alex Chapman +! See http://factorcode.org/license.txt for BSD license. +USING: accessors arrays float-arrays kernel locals math math.constants math.functions math.matrices math.vectors math.quaternions random sequences ; +IN: jamshred.oint + +! An oint is a point with three linearly independent unit vectors +! given relative to that point. In jamshred a player's location and +! direction are given by the player's oint. Similarly, a tunnel +! segment's location and orientation are given by an oint. + +TUPLE: oint location forward up left ; +C: oint + +: rotation-quaternion ( theta axis -- quaternion ) + swap 2 / dup cos swap sin rot n*v first3 rect> >r rect> r> 2array ; + +: rotate-vector ( q qrecip v -- v ) + v>q swap q* q* q>v ; + +: rotate-oint ( oint theta axis -- ) + rotation-quaternion dup qrecip pick + [ forward>> rotate-vector >>forward ] + [ up>> rotate-vector >>up ] + [ left>> rotate-vector >>left ] 3tri drop ; + +: left-pivot ( oint theta -- ) + over left>> rotate-oint ; + +: up-pivot ( oint theta -- ) + over up>> rotate-oint ; + +: forward-pivot ( oint theta -- ) + over forward>> rotate-oint ; + +: random-float+- ( n -- m ) + #! find a random float between -n/2 and n/2 + dup 10000 * >fixnum random 10000 / swap 2 / - ; + +: random-turn ( oint theta -- ) + 2 / 2dup random-float+- left-pivot random-float+- up-pivot ; + +: location+ ( v oint -- ) + [ location>> v+ ] [ (>>location) ] bi ; + +: go-forward ( distance oint -- ) + [ forward>> n*v ] [ location+ ] bi ; + +: distance-vector ( oint oint -- vector ) + [ location>> ] bi@ swap v- ; + +: distance ( oint oint -- distance ) + distance-vector norm ; + +: scalar-projection ( v1 v2 -- n ) + #! the scalar projection of v1 onto v2 + tuck v. swap norm / ; + +: proj-perp ( u v -- w ) + dupd proj v- ; + +: perpendicular-distance ( oint oint -- distance ) + tuck distance-vector swap 2dup left>> scalar-projection abs + -rot up>> scalar-projection abs + ; + +:: reflect ( v n -- v' ) + #! bounce v on a surface with normal n + v v n v. n n v. / 2 * n n*v v- ; + +: half-way ( p1 p2 -- p3 ) + over v- 2 v/n v+ ; + +: half-way-between-oints ( o1 o2 -- p ) + [ location>> ] bi@ half-way ; diff --git a/unmaintained/jamshred/player/authors.txt b/unmaintained/jamshred/player/authors.txt new file mode 100644 index 0000000000..e9c193bac7 --- /dev/null +++ b/unmaintained/jamshred/player/authors.txt @@ -0,0 +1 @@ +Alex Chapman diff --git a/unmaintained/jamshred/player/player.factor b/unmaintained/jamshred/player/player.factor new file mode 100644 index 0000000000..72f26a2c79 --- /dev/null +++ b/unmaintained/jamshred/player/player.factor @@ -0,0 +1,137 @@ +! Copyright (C) 2007, 2008 Alex Chapman +! See http://factorcode.org/license.txt for BSD license. +USING: accessors colors combinators float-arrays jamshred.log jamshred.oint jamshred.sound jamshred.tunnel kernel locals math math.constants math.order math.ranges math.vectors math.matrices sequences shuffle strings system ; +IN: jamshred.player + +TUPLE: player < oint + { name string } + { sounds sounds } + tunnel + nearest-segment + { last-move integer } + { speed float } ; + +! speeds are in GL units / second +: default-speed ( -- speed ) 1.0 ; +: max-speed ( -- speed ) 30.0 ; + +: ( name sounds -- player ) + [ F{ 0 0 5 } F{ 0 0 -1 } F{ 0 1 0 } F{ -1 0 0 } ] 2dip + f f 0 default-speed player boa ; + +: turn-player ( player x-radians y-radians -- ) + >r over r> left-pivot up-pivot ; + +: roll-player ( player z-radians -- ) + forward-pivot ; + +: to-tunnel-start ( player -- ) + [ tunnel>> first dup location>> ] + [ tuck (>>location) (>>nearest-segment) ] bi ; + +: play-in-tunnel ( player segments -- ) + >>tunnel to-tunnel-start ; + +: update-nearest-segment ( player -- ) + [ tunnel>> ] [ dup nearest-segment>> nearest-segment ] + [ (>>nearest-segment) ] tri ; + +: update-time ( player -- seconds-passed ) + millis swap [ last-move>> - 1000 / ] [ (>>last-move) ] 2bi ; + +: moved ( player -- ) millis swap (>>last-move) ; + +: speed-range ( -- range ) + max-speed [0,b] ; + +: change-player-speed ( inc player -- ) + [ + speed-range clamp-to-range ] change-speed drop ; + +: multiply-player-speed ( n player -- ) + [ * speed-range clamp-to-range ] change-speed drop ; + +: distance-to-move ( seconds-passed player -- distance ) + speed>> * ; + +: bounce ( d-left player -- d-left' player ) + { + [ dup nearest-segment>> bounce-off-wall ] + [ sounds>> bang ] + [ 3/4 swap multiply-player-speed ] + [ ] + } cleave ; + +:: (distance) ( heading player -- current next location heading ) + player nearest-segment>> + player [ tunnel>> ] [ nearest-segment>> ] bi heading heading-segment + player location>> heading ; + +: distance-to-heading-segment ( heading player -- distance ) + (distance) distance-to-next-segment ; + +: distance-to-heading-segment-area ( heading player -- distance ) + (distance) distance-to-next-segment-area ; + +: distance-to-collision ( player -- distance ) + dup nearest-segment>> (distance-to-collision) ; + +: almost-to-collision ( player -- distance ) + distance-to-collision 0.1 - dup 0 < [ drop 0 ] when ; + +: from ( player -- radius distance-from-centre ) + [ nearest-segment>> dup radius>> swap ] [ location>> ] bi + distance-from-centre ; + +: distance-from-wall ( player -- distance ) from - ; +: fraction-from-centre ( player -- fraction ) from swap / ; +: fraction-from-wall ( player -- fraction ) + fraction-from-centre 1 swap - ; + +: update-nearest-segment2 ( heading player -- ) + 2dup distance-to-heading-segment-area 0 <= [ + [ tunnel>> ] [ nearest-segment>> rot heading-segment ] + [ (>>nearest-segment) ] tri + ] [ + 2drop + ] if ; + +:: move-player-on-heading ( d-left player distance heading -- d-left' player ) + [let* | d-to-move [ d-left distance min ] + move-v [ d-to-move heading n*v ] | + move-v player location+ + heading player update-nearest-segment2 + d-left d-to-move - player ] ; + +: distance-to-move-freely ( player -- distance ) + [ almost-to-collision ] + [ [ forward>> ] keep distance-to-heading-segment-area ] bi min ; + +: ?move-player-freely ( d-left player -- d-left' player ) + over 0 > [ + ! must make sure we are moving a significant distance, otherwise + ! we can recurse endlessly due to floating-point imprecision. + ! (at least I /think/ that's what causes it...) + dup distance-to-move-freely dup 0.1 > [ + over forward>> move-player-on-heading ?move-player-freely + ] [ drop ] if + ] when ; + +: drag-heading ( player -- heading ) + [ forward>> ] [ nearest-segment>> forward>> proj ] bi ; + +: drag-player ( d-left player -- d-left' player ) + dup [ [ drag-heading ] keep distance-to-heading-segment-area ] + [ drag-heading move-player-on-heading ] bi ; + +: (move-player) ( d-left player -- d-left' player ) + ?move-player-freely over 0 > [ + ! bounce + drag-player + (move-player) + ] when ; + +: move-player ( player -- ) + [ update-time ] [ distance-to-move ] [ (move-player) 2drop ] tri ; + +: update-player ( player -- ) + [ move-player ] [ nearest-segment>> white swap (>>color) ] bi ; diff --git a/unmaintained/jamshred/sound/sound.factor b/unmaintained/jamshred/sound/sound.factor new file mode 100644 index 0000000000..c19c67671f --- /dev/null +++ b/unmaintained/jamshred/sound/sound.factor @@ -0,0 +1,15 @@ +! Copyright (C) 2008 Alex Chapman +! See http://factorcode.org/license.txt for BSD license. +USING: accessors io.files kernel openal sequences ; +IN: jamshred.sound + +TUPLE: sounds bang ; + +: assign-sound ( source wav-path -- ) + resource-path create-buffer-from-wav AL_BUFFER swap set-source-param ; + +: ( -- sounds ) + init-openal 1 gen-sources first sounds boa + dup bang>> "extra/jamshred/sound/bang.wav" assign-sound ; + +: bang ( sounds -- ) bang>> source-play check-error ; diff --git a/unmaintained/jamshred/summary.txt b/unmaintained/jamshred/summary.txt new file mode 100644 index 0000000000..e26fc1cf8b --- /dev/null +++ b/unmaintained/jamshred/summary.txt @@ -0,0 +1 @@ +A simple 3d tunnel racing game diff --git a/unmaintained/jamshred/tags.txt b/unmaintained/jamshred/tags.txt new file mode 100644 index 0000000000..8ae5957a4b --- /dev/null +++ b/unmaintained/jamshred/tags.txt @@ -0,0 +1,2 @@ +applications +games diff --git a/unmaintained/jamshred/tunnel/authors.txt b/unmaintained/jamshred/tunnel/authors.txt new file mode 100644 index 0000000000..e9c193bac7 --- /dev/null +++ b/unmaintained/jamshred/tunnel/authors.txt @@ -0,0 +1 @@ +Alex Chapman diff --git a/unmaintained/jamshred/tunnel/tunnel-tests.factor b/unmaintained/jamshred/tunnel/tunnel-tests.factor new file mode 100644 index 0000000000..9486713f55 --- /dev/null +++ b/unmaintained/jamshred/tunnel/tunnel-tests.factor @@ -0,0 +1,45 @@ +! Copyright (C) 2007, 2008 Alex Chapman +! See http://factorcode.org/license.txt for BSD license. +USING: accessors arrays float-arrays jamshred.oint jamshred.tunnel kernel math.vectors sequences tools.test ; +IN: jamshred.tunnel.tests + +[ 0 ] [ T{ segment f { 0 0 0 } f f f 0 } + T{ segment f { 1 1 1 } f f f 1 } + T{ oint f { 0 0 0.25 } } + nearer-segment number>> ] unit-test + +[ 0 ] [ T{ oint f { 0 0 0 } } find-nearest-segment number>> ] unit-test +[ 1 ] [ T{ oint f { 0 0 -1 } } find-nearest-segment number>> ] unit-test +[ 2 ] [ T{ oint f { 0 0.1 -2.1 } } find-nearest-segment number>> ] unit-test + +[ 3 ] [ T{ oint f { 0 0 -3.25 } } 0 nearest-segment-forward number>> ] unit-test + +[ F{ 0 0 0 } ] [ T{ oint f { 0 0 -0.25 } } over first nearest-segment location>> ] unit-test + +: test-segment-oint ( -- oint ) + { 0 0 0 } { 0 0 -1 } { 0 1 0 } { -1 0 0 } ; + +[ { -1 0 0 } ] [ test-segment-oint { 1 0 0 } vector-to-centre ] unit-test +[ { 1 0 0 } ] [ test-segment-oint { -1 0 0 } vector-to-centre ] unit-test +[ { 0 -1 0 } ] [ test-segment-oint { 0 1 0 } vector-to-centre ] unit-test +[ { 0 1 0 } ] [ test-segment-oint { 0 -1 0 } vector-to-centre ] unit-test +[ { -1 0 0 } ] [ test-segment-oint { 1 0 -1 } vector-to-centre ] unit-test +[ { 1 0 0 } ] [ test-segment-oint { -1 0 -1 } vector-to-centre ] unit-test +[ { 0 -1 0 } ] [ test-segment-oint { 0 1 -1 } vector-to-centre ] unit-test +[ { 0 1 0 } ] [ test-segment-oint { 0 -1 -1 } vector-to-centre ] unit-test + +: simplest-straight-ahead ( -- oint segment ) + { 0 0 0 } { 0 0 -1 } { 0 1 0 } { -1 0 0 } + initial-segment ; + +[ { 0.0 0.0 0.0 } ] [ simplest-straight-ahead sideways-heading ] unit-test +[ { 0.0 0.0 0.0 } ] [ simplest-straight-ahead sideways-relative-location ] unit-test + +: simple-collision-up ( -- oint segment ) + { 0 0 0 } { 0 1 0 } { 0 0 1 } { -1 0 0 } + initial-segment ; + +[ { 0.0 1.0 0.0 } ] [ simple-collision-up sideways-heading ] unit-test +[ { 0.0 0.0 0.0 } ] [ simple-collision-up sideways-relative-location ] unit-test +[ { 0.0 1.0 0.0 } ] +[ simple-collision-up collision-vector 0 0 0 3array v+ ] unit-test diff --git a/unmaintained/jamshred/tunnel/tunnel.factor b/unmaintained/jamshred/tunnel/tunnel.factor new file mode 100644 index 0000000000..52f2d38dd1 --- /dev/null +++ b/unmaintained/jamshred/tunnel/tunnel.factor @@ -0,0 +1,167 @@ +! Copyright (C) 2007, 2008 Alex Chapman +! See http://factorcode.org/license.txt for BSD license. +USING: accessors arrays colors combinators float-arrays kernel +locals math math.constants math.matrices math.order math.ranges +math.vectors math.quadratic random sequences vectors jamshred.oint ; +IN: jamshred.tunnel + +: n-segments ( -- n ) 5000 ; inline + +TUPLE: segment < oint number color radius ; +C: segment + +: segment-number++ ( segment -- ) + [ number>> 1+ ] keep (>>number) ; + +: random-color ( -- color ) + { 100 100 100 } [ random 100 / >float ] map first3 1.0 ; + +: tunnel-segment-distance ( -- n ) 0.4 ; +: random-rotation-angle ( -- theta ) pi 20 / ; + +: random-segment ( previous-segment -- segment ) + clone dup random-rotation-angle random-turn + tunnel-segment-distance over go-forward + random-color >>color dup segment-number++ ; + +: (random-segments) ( segments n -- segments ) + dup 0 > [ + >r dup peek random-segment over push r> 1- (random-segments) + ] [ drop ] if ; + +: default-segment-radius ( -- r ) 1 ; + +: initial-segment ( -- segment ) + F{ 0 0 0 } F{ 0 0 -1 } F{ 0 1 0 } F{ -1 0 0 } + 0 random-color default-segment-radius ; + +: random-segments ( n -- segments ) + initial-segment 1vector swap (random-segments) ; + +: simple-segment ( n -- segment ) + [ F{ 0 0 -1 } n*v F{ 0 0 -1 } F{ 0 1 0 } F{ -1 0 0 } ] keep + random-color default-segment-radius ; + +: simple-segments ( n -- segments ) + [ simple-segment ] map ; + +: ( -- segments ) + n-segments random-segments ; + +: ( -- segments ) + n-segments simple-segments ; + +: sub-tunnel ( from to segments -- segments ) + #! return segments between from and to, after clamping from and to to + #! valid values + [ sequence-index-range [ clamp-to-range ] curry bi@ ] keep ; + +: nearer-segment ( segment segment oint -- segment ) + #! return whichever of the two segments is nearer to the oint + >r 2dup r> tuck distance >r distance r> < -rot ? ; + +: (find-nearest-segment) ( nearest next oint -- nearest ? ) + #! find the nearest of 'next' and 'nearest' to 'oint', and return + #! t if the nearest hasn't changed + pick >r nearer-segment dup r> = ; + +: find-nearest-segment ( oint segments -- segment ) + dup first swap rest-slice rot [ (find-nearest-segment) ] curry + find 2drop ; + +: nearest-segment-forward ( segments oint start -- segment ) + rot dup length swap find-nearest-segment ; + +: nearest-segment-backward ( segments oint start -- segment ) + swapd 1+ 0 spin find-nearest-segment ; + +: nearest-segment ( segments oint start-segment -- segment ) + #! find the segment nearest to 'oint', and return it. + #! start looking at segment 'start-segment' + number>> over >r + [ nearest-segment-forward ] 3keep + nearest-segment-backward r> nearer-segment ; + +: get-segment ( segments n -- segment ) + over sequence-index-range clamp-to-range swap nth ; + +: next-segment ( segments current-segment -- segment ) + number>> 1+ get-segment ; + +: previous-segment ( segments current-segment -- segment ) + number>> 1- get-segment ; + +: heading-segment ( segments current-segment heading -- segment ) + #! the next segment on the given heading + over forward>> v. 0 <=> { + { +gt+ [ next-segment ] } + { +lt+ [ previous-segment ] } + { +eq+ [ nip ] } ! current segment + } case ; + +:: distance-to-next-segment ( current next location heading -- distance ) + [let | cf [ current forward>> ] | + cf next location>> v. cf location v. - cf heading v. / ] ; + +:: distance-to-next-segment-area ( current next location heading -- distance ) + [let | cf [ current forward>> ] + h [ next current half-way-between-oints ] | + cf h v. cf location v. - cf heading v. / ] ; + +: vector-to-centre ( seg loc -- v ) + over location>> swap v- swap forward>> proj-perp ; + +: distance-from-centre ( seg loc -- distance ) + vector-to-centre norm ; + +: wall-normal ( seg oint -- n ) + location>> vector-to-centre normalize ; + +: distant ( -- n ) 1000 ; + +: max-real ( a b -- c ) + #! sometimes collision-coefficient yields complex roots, so we ignore these (hack) + dup real? [ + over real? [ max ] [ nip ] if + ] [ + drop dup real? [ drop distant ] unless + ] if ; + +:: collision-coefficient ( v w r -- c ) + v norm 0 = [ + distant + ] [ + [let* | a [ v dup v. ] + b [ v w v. 2 * ] + c [ w dup v. r sq - ] | + c b a quadratic max-real ] + ] if ; + +: sideways-heading ( oint segment -- v ) + [ forward>> ] bi@ proj-perp ; + +: sideways-relative-location ( oint segment -- loc ) + [ [ location>> ] bi@ v- ] keep forward>> proj-perp ; + +: (distance-to-collision) ( oint segment -- distance ) + [ sideways-heading ] [ sideways-relative-location ] + [ nip radius>> ] 2tri collision-coefficient ; + +: collision-vector ( oint segment -- v ) + dupd (distance-to-collision) swap forward>> n*v ; + +: bounce-forward ( segment oint -- ) + [ wall-normal ] [ forward>> swap reflect ] [ (>>forward) ] tri ; + +: bounce-left ( segment oint -- ) + #! must be done after forward + [ forward>> vneg ] dip [ left>> swap reflect ] + [ forward>> proj-perp normalize ] [ (>>left) ] tri ; + +: bounce-up ( segment oint -- ) + #! must be done after forward and left! + nip [ forward>> ] [ left>> cross ] [ (>>up) ] tri ; + +: bounce-off-wall ( oint segment -- ) + swap [ bounce-forward ] [ bounce-left ] [ bounce-up ] 2tri ; + From 601f8fdd29e8cab8d9306bbe386bae25829c25c6 Mon Sep 17 00:00:00 2001 From: Alex Chapman Date: Wed, 15 Apr 2009 20:01:18 +1000 Subject: [PATCH 15/19] Moving jamshred from unmaintained to extra --- {unmaintained => extra}/jamshred/authors.txt | 0 {unmaintained => extra}/jamshred/deploy.factor | 0 {unmaintained => extra}/jamshred/game/authors.txt | 0 {unmaintained => extra}/jamshred/game/game.factor | 0 {unmaintained => extra}/jamshred/gl/authors.txt | 0 {unmaintained => extra}/jamshred/gl/gl.factor | 0 {unmaintained => extra}/jamshred/jamshred.factor | 0 {unmaintained => extra}/jamshred/log/log.factor | 0 {unmaintained => extra}/jamshred/oint/authors.txt | 0 {unmaintained => extra}/jamshred/oint/oint-tests.factor | 0 {unmaintained => extra}/jamshred/oint/oint.factor | 0 {unmaintained => extra}/jamshred/player/authors.txt | 0 {unmaintained => extra}/jamshred/player/player.factor | 0 {unmaintained => extra}/jamshred/sound/sound.factor | 0 {unmaintained => extra}/jamshred/summary.txt | 0 {unmaintained => extra}/jamshred/tags.txt | 0 {unmaintained => extra}/jamshred/tunnel/authors.txt | 0 {unmaintained => extra}/jamshred/tunnel/tunnel-tests.factor | 0 {unmaintained => extra}/jamshred/tunnel/tunnel.factor | 0 19 files changed, 0 insertions(+), 0 deletions(-) rename {unmaintained => extra}/jamshred/authors.txt (100%) rename {unmaintained => extra}/jamshred/deploy.factor (100%) rename {unmaintained => extra}/jamshred/game/authors.txt (100%) rename {unmaintained => extra}/jamshred/game/game.factor (100%) rename {unmaintained => extra}/jamshred/gl/authors.txt (100%) rename {unmaintained => extra}/jamshred/gl/gl.factor (100%) rename {unmaintained => extra}/jamshred/jamshred.factor (100%) rename {unmaintained => extra}/jamshred/log/log.factor (100%) rename {unmaintained => extra}/jamshred/oint/authors.txt (100%) rename {unmaintained => extra}/jamshred/oint/oint-tests.factor (100%) rename {unmaintained => extra}/jamshred/oint/oint.factor (100%) rename {unmaintained => extra}/jamshred/player/authors.txt (100%) rename {unmaintained => extra}/jamshred/player/player.factor (100%) rename {unmaintained => extra}/jamshred/sound/sound.factor (100%) rename {unmaintained => extra}/jamshred/summary.txt (100%) rename {unmaintained => extra}/jamshred/tags.txt (100%) rename {unmaintained => extra}/jamshred/tunnel/authors.txt (100%) rename {unmaintained => extra}/jamshred/tunnel/tunnel-tests.factor (100%) rename {unmaintained => extra}/jamshred/tunnel/tunnel.factor (100%) diff --git a/unmaintained/jamshred/authors.txt b/extra/jamshred/authors.txt similarity index 100% rename from unmaintained/jamshred/authors.txt rename to extra/jamshred/authors.txt diff --git a/unmaintained/jamshred/deploy.factor b/extra/jamshred/deploy.factor similarity index 100% rename from unmaintained/jamshred/deploy.factor rename to extra/jamshred/deploy.factor diff --git a/unmaintained/jamshred/game/authors.txt b/extra/jamshred/game/authors.txt similarity index 100% rename from unmaintained/jamshred/game/authors.txt rename to extra/jamshred/game/authors.txt diff --git a/unmaintained/jamshred/game/game.factor b/extra/jamshred/game/game.factor similarity index 100% rename from unmaintained/jamshred/game/game.factor rename to extra/jamshred/game/game.factor diff --git a/unmaintained/jamshred/gl/authors.txt b/extra/jamshred/gl/authors.txt similarity index 100% rename from unmaintained/jamshred/gl/authors.txt rename to extra/jamshred/gl/authors.txt diff --git a/unmaintained/jamshred/gl/gl.factor b/extra/jamshred/gl/gl.factor similarity index 100% rename from unmaintained/jamshred/gl/gl.factor rename to extra/jamshred/gl/gl.factor diff --git a/unmaintained/jamshred/jamshred.factor b/extra/jamshred/jamshred.factor similarity index 100% rename from unmaintained/jamshred/jamshred.factor rename to extra/jamshred/jamshred.factor diff --git a/unmaintained/jamshred/log/log.factor b/extra/jamshred/log/log.factor similarity index 100% rename from unmaintained/jamshred/log/log.factor rename to extra/jamshred/log/log.factor diff --git a/unmaintained/jamshred/oint/authors.txt b/extra/jamshred/oint/authors.txt similarity index 100% rename from unmaintained/jamshred/oint/authors.txt rename to extra/jamshred/oint/authors.txt diff --git a/unmaintained/jamshred/oint/oint-tests.factor b/extra/jamshred/oint/oint-tests.factor similarity index 100% rename from unmaintained/jamshred/oint/oint-tests.factor rename to extra/jamshred/oint/oint-tests.factor diff --git a/unmaintained/jamshred/oint/oint.factor b/extra/jamshred/oint/oint.factor similarity index 100% rename from unmaintained/jamshred/oint/oint.factor rename to extra/jamshred/oint/oint.factor diff --git a/unmaintained/jamshred/player/authors.txt b/extra/jamshred/player/authors.txt similarity index 100% rename from unmaintained/jamshred/player/authors.txt rename to extra/jamshred/player/authors.txt diff --git a/unmaintained/jamshred/player/player.factor b/extra/jamshred/player/player.factor similarity index 100% rename from unmaintained/jamshred/player/player.factor rename to extra/jamshred/player/player.factor diff --git a/unmaintained/jamshred/sound/sound.factor b/extra/jamshred/sound/sound.factor similarity index 100% rename from unmaintained/jamshred/sound/sound.factor rename to extra/jamshred/sound/sound.factor diff --git a/unmaintained/jamshred/summary.txt b/extra/jamshred/summary.txt similarity index 100% rename from unmaintained/jamshred/summary.txt rename to extra/jamshred/summary.txt diff --git a/unmaintained/jamshred/tags.txt b/extra/jamshred/tags.txt similarity index 100% rename from unmaintained/jamshred/tags.txt rename to extra/jamshred/tags.txt diff --git a/unmaintained/jamshred/tunnel/authors.txt b/extra/jamshred/tunnel/authors.txt similarity index 100% rename from unmaintained/jamshred/tunnel/authors.txt rename to extra/jamshred/tunnel/authors.txt diff --git a/unmaintained/jamshred/tunnel/tunnel-tests.factor b/extra/jamshred/tunnel/tunnel-tests.factor similarity index 100% rename from unmaintained/jamshred/tunnel/tunnel-tests.factor rename to extra/jamshred/tunnel/tunnel-tests.factor diff --git a/unmaintained/jamshred/tunnel/tunnel.factor b/extra/jamshred/tunnel/tunnel.factor similarity index 100% rename from unmaintained/jamshred/tunnel/tunnel.factor rename to extra/jamshred/tunnel/tunnel.factor From ea903a67ba244a212e29b1e5a73128b51535da74 Mon Sep 17 00:00:00 2001 From: Alex Chapman Date: Thu, 16 Apr 2009 11:05:59 +1000 Subject: [PATCH 16/19] Openal fixes --- {unmaintained => extra}/openal/authors.txt | 0 {unmaintained => extra}/openal/backend/authors.txt | 0 .../openal/backend/backend.factor | 0 {unmaintained => extra}/openal/example/authors.txt | 0 .../openal/example/example.factor | 0 {unmaintained => extra}/openal/macosx/authors.txt | 0 .../openal/macosx/macosx.factor | 4 ++-- {unmaintained => extra}/openal/macosx/tags.txt | 0 {unmaintained => extra}/openal/openal.factor | 14 ++++++-------- {unmaintained => extra}/openal/other/authors.txt | 0 {unmaintained => extra}/openal/other/other.factor | 0 {unmaintained => extra}/openal/summary.txt | 0 {unmaintained => extra}/openal/tags.txt | 0 13 files changed, 8 insertions(+), 10 deletions(-) rename {unmaintained => extra}/openal/authors.txt (100%) rename {unmaintained => extra}/openal/backend/authors.txt (100%) rename {unmaintained => extra}/openal/backend/backend.factor (100%) rename {unmaintained => extra}/openal/example/authors.txt (100%) rename {unmaintained => extra}/openal/example/example.factor (100%) rename {unmaintained => extra}/openal/macosx/authors.txt (100%) rename {unmaintained => extra}/openal/macosx/macosx.factor (84%) rename {unmaintained => extra}/openal/macosx/tags.txt (100%) rename {unmaintained => extra}/openal/openal.factor (96%) rename {unmaintained => extra}/openal/other/authors.txt (100%) rename {unmaintained => extra}/openal/other/other.factor (100%) rename {unmaintained => extra}/openal/summary.txt (100%) rename {unmaintained => extra}/openal/tags.txt (100%) diff --git a/unmaintained/openal/authors.txt b/extra/openal/authors.txt similarity index 100% rename from unmaintained/openal/authors.txt rename to extra/openal/authors.txt diff --git a/unmaintained/openal/backend/authors.txt b/extra/openal/backend/authors.txt similarity index 100% rename from unmaintained/openal/backend/authors.txt rename to extra/openal/backend/authors.txt diff --git a/unmaintained/openal/backend/backend.factor b/extra/openal/backend/backend.factor similarity index 100% rename from unmaintained/openal/backend/backend.factor rename to extra/openal/backend/backend.factor diff --git a/unmaintained/openal/example/authors.txt b/extra/openal/example/authors.txt similarity index 100% rename from unmaintained/openal/example/authors.txt rename to extra/openal/example/authors.txt diff --git a/unmaintained/openal/example/example.factor b/extra/openal/example/example.factor similarity index 100% rename from unmaintained/openal/example/example.factor rename to extra/openal/example/example.factor diff --git a/unmaintained/openal/macosx/authors.txt b/extra/openal/macosx/authors.txt similarity index 100% rename from unmaintained/openal/macosx/authors.txt rename to extra/openal/macosx/authors.txt diff --git a/unmaintained/openal/macosx/macosx.factor b/extra/openal/macosx/macosx.factor similarity index 84% rename from unmaintained/openal/macosx/macosx.factor rename to extra/openal/macosx/macosx.factor index abc0d65fb9..81d360eca1 100644 --- a/unmaintained/openal/macosx/macosx.factor +++ b/extra/openal/macosx/macosx.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2007 Chris Double. ! See http://factorcode.org/license.txt for BSD license. USING: alien.c-types kernel alien alien.syntax shuffle -combinators.lib openal.backend namespaces system ; +openal.backend namespaces system generalizations ; IN: openal.macosx LIBRARY: alut @@ -10,5 +10,5 @@ FUNCTION: void alutLoadWAVFile ( ALbyte* fileName, ALenum* format, void** data, M: macosx load-wav-file ( path -- format data size frequency ) 0 f 0 0 - [ alutLoadWAVFile ] 4keep + [ alutLoadWAVFile ] 4 nkeep [ [ [ *int ] dip *void* ] dip *int ] dip *int ; diff --git a/unmaintained/openal/macosx/tags.txt b/extra/openal/macosx/tags.txt similarity index 100% rename from unmaintained/openal/macosx/tags.txt rename to extra/openal/macosx/tags.txt diff --git a/unmaintained/openal/openal.factor b/extra/openal/openal.factor similarity index 96% rename from unmaintained/openal/openal.factor rename to extra/openal/openal.factor index 8533308f26..6e9721b0fe 100644 --- a/unmaintained/openal/openal.factor +++ b/extra/openal/openal.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2007 Chris Double. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel arrays alien system combinators alien.syntax namespaces +USING: kernel accessors arrays alien system combinators alien.syntax namespaces alien.c-types sequences vocabs.loader shuffle - openal.backend specialized-arrays.uint ; + openal.backend specialized-arrays.uint alien.libraries generalizations ; IN: openal << "alut" { @@ -245,13 +245,11 @@ SYMBOL: init f init set-global ] unless ; -: ( n -- byte-array ) "ALuint" ; - : gen-sources ( size -- seq ) - dup 2dup underlying>> alGenSources swap ; + dup [ alGenSources ] keep ; : gen-buffers ( size -- seq ) - dup 2dup underlying>> alGenBuffers swap ; + dup [ alGenBuffers ] keep ; : gen-buffer ( -- buffer ) 1 gen-buffers first ; @@ -264,10 +262,10 @@ os macosx? "openal.macosx" "openal.other" ? require : create-buffer-from-wav ( filename -- buffer ) gen-buffer dup rot load-wav-file - [ alBufferData ] 4keep alutUnloadWAV ; + [ alBufferData ] 4 nkeep alutUnloadWAV ; : queue-buffers ( source buffers -- ) - [ length ] [ >uint-array underlying>> ] bi alSourceQueueBuffers ; + [ length ] [ >uint-array ] bi alSourceQueueBuffers ; : queue-buffer ( source buffer -- ) 1array queue-buffers ; diff --git a/unmaintained/openal/other/authors.txt b/extra/openal/other/authors.txt similarity index 100% rename from unmaintained/openal/other/authors.txt rename to extra/openal/other/authors.txt diff --git a/unmaintained/openal/other/other.factor b/extra/openal/other/other.factor similarity index 100% rename from unmaintained/openal/other/other.factor rename to extra/openal/other/other.factor diff --git a/unmaintained/openal/summary.txt b/extra/openal/summary.txt similarity index 100% rename from unmaintained/openal/summary.txt rename to extra/openal/summary.txt diff --git a/unmaintained/openal/tags.txt b/extra/openal/tags.txt similarity index 100% rename from unmaintained/openal/tags.txt rename to extra/openal/tags.txt From f02bbb6f4baba7f556e3f821d9b8903e4fb7d0ef Mon Sep 17 00:00:00 2001 From: Alex Chapman Date: Thu, 16 Apr 2009 11:06:28 +1000 Subject: [PATCH 17/19] jamshred fixes, but still has an endless recursion bug --- extra/jamshred/gl/gl.factor | 33 ++++++++++++++++------- extra/jamshred/jamshred.factor | 30 ++++++++++----------- extra/jamshred/oint/oint.factor | 4 +-- extra/jamshred/player/player.factor | 8 +++--- extra/jamshred/sound/sound.factor | 2 +- extra/jamshred/tunnel/tunnel-tests.factor | 4 +-- extra/jamshred/tunnel/tunnel.factor | 20 +++++++------- 7 files changed, 56 insertions(+), 45 deletions(-) diff --git a/extra/jamshred/gl/gl.factor b/extra/jamshred/gl/gl.factor index b78e7de88e..bae275e96a 100644 --- a/extra/jamshred/gl/gl.factor +++ b/extra/jamshred/gl/gl.factor @@ -6,8 +6,8 @@ math.functions math.vectors opengl opengl.gl opengl.glu opengl.demo-support sequences specialized-arrays.float ; IN: jamshred.gl -: min-vertices 6 ; inline -: max-vertices 32 ; inline +: min-vertices ( -- n ) 6 ; inline +: max-vertices ( -- n ) 32 ; inline : n-vertices ( -- n ) 32 ; inline @@ -55,7 +55,7 @@ IN: jamshred.gl : draw-segment ( next-segment segment -- ) GL_QUAD_STRIP [ [ draw-vertex-pair ] 2curry - n-vertices equally-spaced-radians F{ 0.0 } append swap each + n-vertices equally-spaced-radians float-array{ 0.0 } append swap each ] do-state ; : draw-segments ( segments -- ) @@ -68,15 +68,13 @@ IN: jamshred.gl : draw-tunnel ( player -- ) segments-to-render draw-segments ; -: init-graphics ( width height -- ) +: init-graphics ( -- ) GL_DEPTH_TEST glEnable GL_SCISSOR_TEST glDisable 1.0 glClearDepth 0.0 0.0 0.0 0.0 glClearColor - GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT bitor glClear - GL_PROJECTION glMatrixMode glLoadIdentity - dup 0 = [ 2drop ] [ / >float 45.0 swap 0.1 100.0 gluPerspective ] if - GL_MODELVIEW glMatrixMode glLoadIdentity + GL_PROJECTION glMatrixMode glPushMatrix + GL_MODELVIEW glMatrixMode glPushMatrix GL_LEQUAL glDepthFunc GL_LIGHTING glEnable GL_LIGHT0 glEnable @@ -89,11 +87,26 @@ IN: jamshred.gl GL_LIGHT0 GL_DIFFUSE float-array{ 1.0 1.0 1.0 1.0 } underlying>> glLightfv GL_LIGHT0 GL_SPECULAR float-array{ 1.0 1.0 1.0 1.0 } underlying>> glLightfv ; +: cleanup-graphics ( -- ) + GL_DEPTH_TEST glDisable + GL_SCISSOR_TEST glEnable + GL_MODELVIEW glMatrixMode glPopMatrix + GL_PROJECTION glMatrixMode glPopMatrix + GL_LIGHTING glDisable + GL_LIGHT0 glDisable + GL_FOG glDisable + GL_COLOR_MATERIAL glDisable ; + +: pre-draw ( width height -- ) + GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT bitor glClear + GL_PROJECTION glMatrixMode glLoadIdentity + dup 0 = [ 2drop ] [ / >float 45.0 swap 0.1 100.0 gluPerspective ] if + GL_MODELVIEW glMatrixMode glLoadIdentity ; + : player-view ( player -- ) [ location>> ] [ [ location>> ] [ forward>> ] bi v+ ] [ up>> ] tri gl-look-at ; : draw-jamshred ( jamshred width height -- ) - init-graphics jamshred-player [ player-view ] [ draw-tunnel ] bi ; - + pre-draw jamshred-player [ player-view ] [ draw-tunnel ] bi ; diff --git a/extra/jamshred/jamshred.factor b/extra/jamshred/jamshred.factor index d0b74417d1..49624e2947 100644 --- a/extra/jamshred/jamshred.factor +++ b/extra/jamshred/jamshred.factor @@ -1,12 +1,12 @@ ! Copyright (C) 2007, 2008 Alex Chapman ! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays calendar jamshred.game jamshred.gl jamshred.player jamshred.log kernel math math.constants math.geometry.rect math.vectors namespaces sequences threads ui ui.backend ui.gadgets ui.gadgets.worlds ui.gestures ui.render ; +USING: accessors arrays calendar jamshred.game jamshred.gl jamshred.player jamshred.log kernel math math.constants math.rectangles math.vectors namespaces sequences threads ui ui.backend ui.gadgets ui.gadgets.worlds ui.gestures ui.render ; IN: jamshred TUPLE: jamshred-gadget < gadget { jamshred jamshred } last-hand-loc ; : ( jamshred -- gadget ) - jamshred-gadget new-gadget swap >>jamshred ; + jamshred-gadget new swap >>jamshred ; : default-width ( -- x ) 800 ; : default-height ( -- y ) 600 ; @@ -15,7 +15,7 @@ M: jamshred-gadget pref-dim* drop default-width default-height 2array ; M: jamshred-gadget draw-gadget* ( gadget -- ) - [ jamshred>> ] [ rect-dim first2 draw-jamshred ] bi ; + [ jamshred>> ] [ dim>> first2 draw-jamshred ] bi ; : jamshred-loop ( gadget -- ) dup jamshred>> quit>> [ @@ -23,7 +23,7 @@ M: jamshred-gadget draw-gadget* ( gadget -- ) ] [ [ jamshred>> jamshred-update ] [ relayout-1 ] - [ 10 milliseconds sleep yield jamshred-loop ] tri + [ 100 milliseconds sleep jamshred-loop ] tri ] if ; : fullscreen ( gadget -- ) @@ -36,10 +36,11 @@ M: jamshred-gadget draw-gadget* ( gadget -- ) [ fullscreen? not ] keep set-fullscreen* ; M: jamshred-gadget graft* ( gadget -- ) - [ jamshred-loop ] curry in-thread ; + [ find-gl-context init-graphics ] + [ [ jamshred-loop ] curry in-thread ] bi ; M: jamshred-gadget ungraft* ( gadget -- ) - jamshred>> t swap (>>quit) ; + dup find-gl-context cleanup-graphics jamshred>> t swap (>>quit) ; : jamshred-restart ( jamshred-gadget -- ) >>jamshred drop ; @@ -49,16 +50,15 @@ M: jamshred-gadget ungraft* ( gadget -- ) : x>radians ( x gadget -- theta ) #! translate motion of x pixels to an angle - rect-dim first pix>radians neg ; + dim>> first pix>radians neg ; : y>radians ( y gadget -- theta ) #! translate motion of y pixels to an angle - rect-dim second pix>radians ; + dim>> second pix>radians ; : (handle-mouse-motion) ( jamshred-gadget mouse-motion -- ) - over jamshred>> >r - [ first swap x>radians ] 2keep second swap y>radians - r> mouse-moved ; + dupd [ first swap x>radians ] [ second swap y>radians ] 2bi + rot jamshred>> mouse-moved ; : handle-mouse-motion ( jamshred-gadget -- ) hand-loc get [ @@ -84,11 +84,11 @@ jamshred-gadget H{ { T{ key-down f f "LEFT" } [ jamshred>> 1 jamshred-roll ] } { T{ key-down f f "RIGHT" } [ jamshred>> -1 jamshred-roll ] } { T{ key-down f f "q" } [ quit ] } - { T{ motion } [ handle-mouse-motion ] } - { T{ mouse-scroll } [ handle-mouse-scroll ] } + { motion [ handle-mouse-motion ] } + { mouse-scroll [ handle-mouse-scroll ] } } set-gestures -: jamshred-window ( -- gadget ) - [ dup "Jamshred" open-window ] with-ui ; +: jamshred-window ( -- ) + [ "Jamshred" open-window ] with-ui ; MAIN: jamshred-window diff --git a/extra/jamshred/oint/oint.factor b/extra/jamshred/oint/oint.factor index 808e92a1f9..ae72bd847c 100644 --- a/extra/jamshred/oint/oint.factor +++ b/extra/jamshred/oint/oint.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2007, 2008 Alex Chapman ! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays float-arrays kernel locals math math.constants math.functions math.matrices math.vectors math.quaternions random sequences ; +USING: accessors arrays kernel locals math math.constants math.functions math.matrices math.vectors math.quaternions random sequences ; IN: jamshred.oint ! An oint is a point with three linearly independent unit vectors @@ -12,7 +12,7 @@ TUPLE: oint location forward up left ; C: oint : rotation-quaternion ( theta axis -- quaternion ) - swap 2 / dup cos swap sin rot n*v first3 rect> >r rect> r> 2array ; + swap 2 / dup cos swap sin rot n*v first3 rect> [ rect> ] dip 2array ; : rotate-vector ( q qrecip v -- v ) v>q swap q* q* q>v ; diff --git a/extra/jamshred/player/player.factor b/extra/jamshred/player/player.factor index 72f26a2c79..d33b78f29c 100644 --- a/extra/jamshred/player/player.factor +++ b/extra/jamshred/player/player.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2007, 2008 Alex Chapman ! See http://factorcode.org/license.txt for BSD license. -USING: accessors colors combinators float-arrays jamshred.log jamshred.oint jamshred.sound jamshred.tunnel kernel locals math math.constants math.order math.ranges math.vectors math.matrices sequences shuffle strings system ; +USING: accessors colors.constants combinators jamshred.log jamshred.oint jamshred.sound jamshred.tunnel kernel locals math math.constants math.order math.ranges math.vectors math.matrices sequences shuffle specialized-arrays.float strings system ; IN: jamshred.player TUPLE: player < oint @@ -16,11 +16,11 @@ TUPLE: player < oint : max-speed ( -- speed ) 30.0 ; : ( name sounds -- player ) - [ F{ 0 0 5 } F{ 0 0 -1 } F{ 0 1 0 } F{ -1 0 0 } ] 2dip + [ float-array{ 0 0 5 } float-array{ 0 0 -1 } float-array{ 0 1 0 } float-array{ -1 0 0 } ] 2dip f f 0 default-speed player boa ; : turn-player ( player x-radians y-radians -- ) - >r over r> left-pivot up-pivot ; + [ over ] dip left-pivot up-pivot ; : roll-player ( player z-radians -- ) forward-pivot ; @@ -134,4 +134,4 @@ TUPLE: player < oint [ update-time ] [ distance-to-move ] [ (move-player) 2drop ] tri ; : update-player ( player -- ) - [ move-player ] [ nearest-segment>> white swap (>>color) ] bi ; + [ move-player ] [ nearest-segment>> "white" named-color swap (>>color) ] bi ; diff --git a/extra/jamshred/sound/sound.factor b/extra/jamshred/sound/sound.factor index c19c67671f..6a9b331f33 100644 --- a/extra/jamshred/sound/sound.factor +++ b/extra/jamshred/sound/sound.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Alex Chapman ! See http://factorcode.org/license.txt for BSD license. -USING: accessors io.files kernel openal sequences ; +USING: accessors io.pathnames kernel openal sequences ; IN: jamshred.sound TUPLE: sounds bang ; diff --git a/extra/jamshred/tunnel/tunnel-tests.factor b/extra/jamshred/tunnel/tunnel-tests.factor index 9486713f55..8e2f1a6fab 100644 --- a/extra/jamshred/tunnel/tunnel-tests.factor +++ b/extra/jamshred/tunnel/tunnel-tests.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2007, 2008 Alex Chapman ! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays float-arrays jamshred.oint jamshred.tunnel kernel math.vectors sequences tools.test ; +USING: accessors arrays jamshred.oint jamshred.tunnel kernel math.vectors sequences specialized-arrays.float tools.test ; IN: jamshred.tunnel.tests [ 0 ] [ T{ segment f { 0 0 0 } f f f 0 } @@ -14,7 +14,7 @@ IN: jamshred.tunnel.tests [ 3 ] [ T{ oint f { 0 0 -3.25 } } 0 nearest-segment-forward number>> ] unit-test -[ F{ 0 0 0 } ] [ T{ oint f { 0 0 -0.25 } } over first nearest-segment location>> ] unit-test +[ float-array{ 0 0 0 } ] [ T{ oint f { 0 0 -0.25 } } over first nearest-segment location>> ] unit-test : test-segment-oint ( -- oint ) { 0 0 0 } { 0 0 -1 } { 0 1 0 } { -1 0 0 } ; diff --git a/extra/jamshred/tunnel/tunnel.factor b/extra/jamshred/tunnel/tunnel.factor index 52f2d38dd1..4c4b3e6812 100644 --- a/extra/jamshred/tunnel/tunnel.factor +++ b/extra/jamshred/tunnel/tunnel.factor @@ -1,8 +1,6 @@ ! Copyright (C) 2007, 2008 Alex Chapman ! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays colors combinators float-arrays kernel -locals math math.constants math.matrices math.order math.ranges -math.vectors math.quadratic random sequences vectors jamshred.oint ; +USING: accessors arrays colors combinators kernel locals math math.constants math.matrices math.order math.ranges math.vectors math.quadratic random sequences specialized-arrays.float vectors jamshred.oint ; IN: jamshred.tunnel : n-segments ( -- n ) 5000 ; inline @@ -26,20 +24,20 @@ C: segment : (random-segments) ( segments n -- segments ) dup 0 > [ - >r dup peek random-segment over push r> 1- (random-segments) + [ dup peek random-segment over push ] dip 1- (random-segments) ] [ drop ] if ; : default-segment-radius ( -- r ) 1 ; : initial-segment ( -- segment ) - F{ 0 0 0 } F{ 0 0 -1 } F{ 0 1 0 } F{ -1 0 0 } + float-array{ 0 0 0 } float-array{ 0 0 -1 } float-array{ 0 1 0 } float-array{ -1 0 0 } 0 random-color default-segment-radius ; : random-segments ( n -- segments ) initial-segment 1vector swap (random-segments) ; : simple-segment ( n -- segment ) - [ F{ 0 0 -1 } n*v F{ 0 0 -1 } F{ 0 1 0 } F{ -1 0 0 } ] keep + [ float-array{ 0 0 -1 } n*v float-array{ 0 0 -1 } float-array{ 0 1 0 } float-array{ -1 0 0 } ] keep random-color default-segment-radius ; : simple-segments ( n -- segments ) @@ -58,12 +56,12 @@ C: segment : nearer-segment ( segment segment oint -- segment ) #! return whichever of the two segments is nearer to the oint - >r 2dup r> tuck distance >r distance r> < -rot ? ; + [ 2dup ] dip tuck distance [ distance ] dip < -rot ? ; : (find-nearest-segment) ( nearest next oint -- nearest ? ) #! find the nearest of 'next' and 'nearest' to 'oint', and return #! t if the nearest hasn't changed - pick >r nearer-segment dup r> = ; + pick [ nearer-segment dup ] dip = ; : find-nearest-segment ( oint segments -- segment ) dup first swap rest-slice rot [ (find-nearest-segment) ] curry @@ -78,9 +76,9 @@ C: segment : nearest-segment ( segments oint start-segment -- segment ) #! find the segment nearest to 'oint', and return it. #! start looking at segment 'start-segment' - number>> over >r - [ nearest-segment-forward ] 3keep - nearest-segment-backward r> nearer-segment ; + number>> over [ + [ nearest-segment-forward ] 3keep nearest-segment-backward + ] dip nearer-segment ; : get-segment ( segments n -- segment ) over sequence-index-range clamp-to-range swap nth ; From 4934c49f0880c53ce8381c6620d1b2b62484678b Mon Sep 17 00:00:00 2001 From: Alex Chapman Date: Thu, 16 Apr 2009 13:36:21 +1000 Subject: [PATCH 18/19] Moving synth and morse from unmaintained to extra --- {unmaintained => extra}/morse/authors.txt | 0 {unmaintained => extra}/morse/morse-docs.factor | 0 {unmaintained => extra}/morse/morse-tests.factor | 0 {unmaintained => extra}/morse/morse.factor | 0 {unmaintained => extra}/morse/summary.txt | 0 {unmaintained => extra}/morse/tags.txt | 0 {unmaintained => extra}/synth/authors.txt | 0 {unmaintained => extra}/synth/buffers/authors.txt | 0 {unmaintained => extra}/synth/buffers/buffers.factor | 0 {unmaintained => extra}/synth/example/authors.txt | 0 {unmaintained => extra}/synth/example/example.factor | 0 {unmaintained => extra}/synth/summary.txt | 0 {unmaintained => extra}/synth/synth.factor | 0 13 files changed, 0 insertions(+), 0 deletions(-) rename {unmaintained => extra}/morse/authors.txt (100%) rename {unmaintained => extra}/morse/morse-docs.factor (100%) rename {unmaintained => extra}/morse/morse-tests.factor (100%) rename {unmaintained => extra}/morse/morse.factor (100%) rename {unmaintained => extra}/morse/summary.txt (100%) rename {unmaintained => extra}/morse/tags.txt (100%) rename {unmaintained => extra}/synth/authors.txt (100%) rename {unmaintained => extra}/synth/buffers/authors.txt (100%) rename {unmaintained => extra}/synth/buffers/buffers.factor (100%) rename {unmaintained => extra}/synth/example/authors.txt (100%) rename {unmaintained => extra}/synth/example/example.factor (100%) rename {unmaintained => extra}/synth/summary.txt (100%) rename {unmaintained => extra}/synth/synth.factor (100%) diff --git a/unmaintained/morse/authors.txt b/extra/morse/authors.txt similarity index 100% rename from unmaintained/morse/authors.txt rename to extra/morse/authors.txt diff --git a/unmaintained/morse/morse-docs.factor b/extra/morse/morse-docs.factor similarity index 100% rename from unmaintained/morse/morse-docs.factor rename to extra/morse/morse-docs.factor diff --git a/unmaintained/morse/morse-tests.factor b/extra/morse/morse-tests.factor similarity index 100% rename from unmaintained/morse/morse-tests.factor rename to extra/morse/morse-tests.factor diff --git a/unmaintained/morse/morse.factor b/extra/morse/morse.factor similarity index 100% rename from unmaintained/morse/morse.factor rename to extra/morse/morse.factor diff --git a/unmaintained/morse/summary.txt b/extra/morse/summary.txt similarity index 100% rename from unmaintained/morse/summary.txt rename to extra/morse/summary.txt diff --git a/unmaintained/morse/tags.txt b/extra/morse/tags.txt similarity index 100% rename from unmaintained/morse/tags.txt rename to extra/morse/tags.txt diff --git a/unmaintained/synth/authors.txt b/extra/synth/authors.txt similarity index 100% rename from unmaintained/synth/authors.txt rename to extra/synth/authors.txt diff --git a/unmaintained/synth/buffers/authors.txt b/extra/synth/buffers/authors.txt similarity index 100% rename from unmaintained/synth/buffers/authors.txt rename to extra/synth/buffers/authors.txt diff --git a/unmaintained/synth/buffers/buffers.factor b/extra/synth/buffers/buffers.factor similarity index 100% rename from unmaintained/synth/buffers/buffers.factor rename to extra/synth/buffers/buffers.factor diff --git a/unmaintained/synth/example/authors.txt b/extra/synth/example/authors.txt similarity index 100% rename from unmaintained/synth/example/authors.txt rename to extra/synth/example/authors.txt diff --git a/unmaintained/synth/example/example.factor b/extra/synth/example/example.factor similarity index 100% rename from unmaintained/synth/example/example.factor rename to extra/synth/example/example.factor diff --git a/unmaintained/synth/summary.txt b/extra/synth/summary.txt similarity index 100% rename from unmaintained/synth/summary.txt rename to extra/synth/summary.txt diff --git a/unmaintained/synth/synth.factor b/extra/synth/synth.factor similarity index 100% rename from unmaintained/synth/synth.factor rename to extra/synth/synth.factor From f491dba93624cef565cdea7101a6258cfea70fad Mon Sep 17 00:00:00 2001 From: Alex Chapman Date: Thu, 16 Apr 2009 13:36:54 +1000 Subject: [PATCH 19/19] Morse an synth fixed --- extra/morse/morse.factor | 12 ++++++------ extra/synth/buffers/buffers.factor | 12 ++++++------ 2 files changed, 12 insertions(+), 12 deletions(-) diff --git a/extra/morse/morse.factor b/extra/morse/morse.factor index 2951c96077..54abce9395 100644 --- a/extra/morse/morse.factor +++ b/extra/morse/morse.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2007, 2008 Alex Chapman ! See http://factorcode.org/license.txt for BSD license. -USING: accessors assocs combinators hashtables kernel lists math +USING: accessors ascii assocs combinators hashtables kernel lists math namespaces make openal parser-combinators promises sequences -strings symbols synth synth.buffers unicode.case ; +strings synth synth.buffers unicode.case ; IN: morse ( -- buffer ) half-sample-freq <8bit-mono-buffer> ; @@ -160,7 +160,7 @@ SYMBOLS: source dot-buffer dash-buffer intra-char-gap-buffer letter-gap-buffer ; init-openal 1 gen-sources first source set make-buffers call source get source-play - ] with-scope ; + ] with-scope ; inline : play-char ( ch -- ) [ intra-char-gap ] [ @@ -176,7 +176,7 @@ PRIVATE> : play-as-morse* ( str unit-length -- ) [ [ letter-gap ] [ ch>morse play-char ] interleave - ] swap playing-morse ; + ] swap playing-morse ; inline : play-as-morse ( str -- ) - 0.05 play-as-morse* ; + 0.05 play-as-morse* ; inline diff --git a/extra/synth/buffers/buffers.factor b/extra/synth/buffers/buffers.factor index b0128ca52a..671ebead63 100644 --- a/extra/synth/buffers/buffers.factor +++ b/extra/synth/buffers/buffers.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Alex Chapman ! See http://factorcode.org/license.txt for BSD license. -USING: accessors alien.c-types combinators kernel locals math math.ranges openal sequences sequences.merged ; +USING: accessors alien.c-types combinators kernel locals math math.ranges openal sequences sequences.merged specialized-arrays.uchar specialized-arrays.short ; IN: synth.buffers TUPLE: buffer sample-freq 8bit? id ; @@ -57,11 +57,11 @@ M: 8bit-stereo-buffer buffer-data M: 16bit-stereo-buffer buffer-data interleaved-stereo-data 16bit-buffer-data ; -: telephone-sample-freq 8000 ; -: half-sample-freq 22050 ; -: cd-sample-freq 44100 ; -: digital-sample-freq 48000 ; -: professional-sample-freq 88200 ; +: telephone-sample-freq ( -- n ) 8000 ; +: half-sample-freq ( -- n ) 22050 ; +: cd-sample-freq ( -- n ) 44100 ; +: digital-sample-freq ( -- n ) 48000 ; +: professional-sample-freq ( -- n ) 88200 ; : send-buffer ( buffer -- buffer ) {