From: Slava Pestov Date: Sat, 6 Sep 2008 00:29:14 +0000 (-0500) Subject: Fixing basis -> extra dependencies X-Git-Tag: 0.94~2439^2~125 X-Git-Url: https://gitweb.factorcode.org/gitweb.cgi?p=factor.git;a=commitdiff_plain;h=aea0fed14c26bb9ef5e1b0e9a3cddd7578566f44 Fixing basis -> extra dependencies --- diff --git a/basis/channels/channels.factor b/basis/channels/channels.factor index 9b5cbee04b..545d8a0e1d 100755 --- a/basis/channels/channels.factor +++ b/basis/channels/channels.factor @@ -2,8 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. ! ! Channels - based on ideas from newsqueak -USING: kernel sequences sequences.lib threads continuations -random math accessors ; +USING: kernel sequences threads continuations +random math accessors random ; IN: channels TUPLE: channel receivers senders ; diff --git a/basis/checksums/common/authors.txt b/basis/checksums/common/authors.txt new file mode 100644 index 0000000000..7c1b2f2279 --- /dev/null +++ b/basis/checksums/common/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/basis/checksums/common/common.factor b/basis/checksums/common/common.factor new file mode 100644 index 0000000000..ea1c6f5b39 --- /dev/null +++ b/basis/checksums/common/common.factor @@ -0,0 +1,21 @@ +! Copyright (C) 2006, 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel math math.bitwise strings io.binary namespaces +grouping ; +IN: checksums.common + +SYMBOL: bytes-read + +: calculate-pad-length ( length -- pad-length ) + dup 56 < 55 119 ? swap - ; + +: pad-last-block ( str big-endian? length -- str ) + [ + rot % + HEX: 80 , + dup HEX: 3f bitand calculate-pad-length 0 % + 3 shift 8 rot [ >be ] [ >le ] if % + ] "" make 64 group ; + +: update-old-new ( old new -- ) + [ get >r get r> ] 2keep >r >r w+ dup r> set r> set ; inline diff --git a/basis/checksums/common/summary.txt b/basis/checksums/common/summary.txt new file mode 100644 index 0000000000..0956c052a4 --- /dev/null +++ b/basis/checksums/common/summary.txt @@ -0,0 +1 @@ +Some code shared by MD5, SHA1 and SHA2 implementations diff --git a/basis/checksums/md5/md5.factor b/basis/checksums/md5/md5.factor index f0e0c71c19..6158254f84 100755 --- a/basis/checksums/md5/md5.factor +++ b/basis/checksums/md5/md5.factor @@ -1,11 +1,14 @@ -! See http://www.faqs.org/rfcs/rfc1321.html - +! Copyright (C) 2006, 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. USING: kernel io io.binary io.files io.streams.byte-array math math.functions math.parser namespaces splitting grouping strings -sequences crypto.common byte-arrays locals sequences.private -io.encodings.binary symbols math.bitfields.lib checksums ; +sequences byte-arrays locals sequences.private +io.encodings.binary symbols math.bitwise checksums +checksums.common ; IN: checksums.md5 +! See http://www.faqs.org/rfcs/rfc1321.html + be> ; inline + : make-w ( str -- ) #! compute w, steps a-b of RFC 3174, section 6.1 16 [ nth-int-be w get push ] with each @@ -113,6 +118,14 @@ INSTANCE: sha1 checksum M: sha1 checksum-stream ( stream -- sha1 ) drop [ initialize-sha1 stream>sha1 get-sha1 ] with-input-stream ; +: seq>2seq ( seq -- seq1 seq2 ) + #! { abcdefgh } -> { aceg } { bdfh } + 2 group flip dup empty? [ drop { } { } ] [ first2 ] if ; + +: 2seq>seq ( seq1 seq2 -- seq ) + #! { aceg } { bdfh } -> { abcdefgh } + [ zip concat ] keep like ; + : sha1-interleave ( string -- seq ) [ zero? ] left-trim dup length odd? [ rest ] when diff --git a/basis/checksums/sha2/sha2.factor b/basis/checksums/sha2/sha2.factor index 6cf7914e6c..ac93c05260 100755 --- a/basis/checksums/sha2/sha2.factor +++ b/basis/checksums/sha2/sha2.factor @@ -1,6 +1,8 @@ -USING: crypto.common kernel splitting grouping -math sequences namespaces io.binary symbols -math.bitfields.lib checksums ; +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel splitting grouping math sequences namespaces +io.binary symbols math.bitwise checksums checksums.common +sbufs strings ; IN: checksums.sha2 r dup 3 + r> first3 ; inline + : T1 ( W n -- T1 ) [ swap nth ] keep K get nth + @@ -112,6 +116,15 @@ SYMBOLS: vars M K H S0 S1 process-M word-size block-size ; : seq>byte-array ( n seq -- string ) [ swap [ >be % ] curry each ] B{ } make ; +: preprocess-plaintext ( string big-endian? -- padded-string ) + #! pad 0x80 then 00 til 8 bytes left, then 64bit length in bits + >r >sbuf r> over [ + HEX: 80 , + dup length HEX: 3f bitand + calculate-pad-length 0 % + length 3 shift 8 rot [ >be ] [ >le ] if % + ] "" make over push-all ; + : byte-array>sha2 ( byte-array -- string ) t preprocess-plaintext block-size get group [ process-chunk ] each diff --git a/basis/cocoa/windows/windows.factor b/basis/cocoa/windows/windows.factor index 74a181f9a2..dd2d1bfd41 100755 --- a/basis/cocoa/windows/windows.factor +++ b/basis/cocoa/windows/windows.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2006, 2007 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. USING: arrays kernel math cocoa cocoa.messages cocoa.classes -sequences math.bitfields ; +sequences math.bitwise ; IN: cocoa.windows : NSBorderlessWindowMask 0 ; inline diff --git a/basis/compiler/generator/fixup/fixup.factor b/basis/compiler/generator/fixup/fixup.factor index ae30502524..5a3337fb32 100755 --- a/basis/compiler/generator/fixup/fixup.factor +++ b/basis/compiler/generator/fixup/fixup.factor @@ -3,7 +3,7 @@ USING: arrays byte-arrays generic assocs hashtables io.binary kernel kernel.private math namespaces sequences words quotations strings alien.accessors alien.strings layouts system -combinators math.bitfields words.private cpu.architecture +combinators math.bitwise words.private cpu.architecture math.order accessors growable ; IN: compiler.generator.fixup diff --git a/basis/cpu/ppc/assembler/backend/backend.factor b/basis/cpu/ppc/assembler/backend/backend.factor index 072f50520c..b881f5a974 100644 --- a/basis/cpu/ppc/assembler/backend/backend.factor +++ b/basis/cpu/ppc/assembler/backend/backend.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: compiler.generator.fixup kernel namespaces sequences -words math math.bitfields io.binary parser lexer ; +words math math.bitwise io.binary parser lexer ; IN: cpu.ppc.assembler.backend : insn ( operand opcode -- ) { 26 0 } bitfield , ; diff --git a/basis/db/db.factor b/basis/db/db.factor index c269341240..10da653c9f 100755 --- a/basis/db/db.factor +++ b/basis/db/db.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: arrays assocs classes continuations destructors kernel math -namespaces sequences sequences.lib classes.tuple words strings -tools.walker accessors combinators.lib combinators ; +namespaces sequences classes.tuple words strings +tools.walker accessors combinators ; IN: db TUPLE: db diff --git a/basis/db/postgresql/postgresql.factor b/basis/db/postgresql/postgresql.factor index 692241fab0..d833063b51 100755 --- a/basis/db/postgresql/postgresql.factor +++ b/basis/db/postgresql/postgresql.factor @@ -4,8 +4,8 @@ USING: arrays assocs alien alien.syntax continuations io kernel math math.parser namespaces prettyprint quotations sequences debugger db db.postgresql.lib db.postgresql.ffi db.tuples db.types tools.annotations math.ranges -combinators sequences.lib classes locals words tools.walker -namespaces.lib accessors random db.queries destructors ; +combinators classes locals words tools.walker +nmake accessors random db.queries destructors ; USE: tools.walker IN: db.postgresql diff --git a/basis/db/queries/queries.factor b/basis/db/queries/queries.factor index e5334703f6..a28f283d30 100644 --- a/basis/db/queries/queries.factor +++ b/basis/db/queries/queries.factor @@ -1,9 +1,8 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors kernel math namespaces sequences random -strings math.parser math.intervals combinators -math.bitfields.lib namespaces.lib db db.tuples db.types -sequences.lib db.sql classes words shuffle arrays ; +USING: accessors kernel math namespaces sequences random strings +math.parser math.intervals combinators math.bitwise nmake db +db.tuples db.types db.sql classes words shuffle arrays ; IN: db.queries GENERIC: where ( specs obj -- ) @@ -142,8 +141,8 @@ M: db ( tuple class -- statement ) : make-query ( tuple query -- tuple' ) dupd { - [ group>> [ do-group ] [ drop ] if-seq ] - [ order>> [ do-order ] [ drop ] if-seq ] + [ group>> [ drop ] [ do-group ] if-empty ] + [ order>> [ drop ] [ do-order ] if-empty ] [ limit>> [ do-limit ] [ drop ] if* ] [ offset>> [ do-offset ] [ drop ] if* ] } 2cleave ; diff --git a/basis/db/sql/sql.factor b/basis/db/sql/sql.factor index 7dd4abf4be..06428485e1 100755 --- a/basis/db/sql/sql.factor +++ b/basis/db/sql/sql.factor @@ -1,6 +1,6 @@ USING: kernel parser quotations classes.tuple words math.order -namespaces.lib namespaces sequences arrays combinators -prettyprint strings math.parser sequences.lib math symbols ; +nmake namespaces sequences arrays combinators +prettyprint strings math.parser math symbols ; IN: db.sql SYMBOLS: insert update delete select distinct columns from as diff --git a/basis/db/sqlite/sqlite.factor b/basis/db/sqlite/sqlite.factor index 49d79b1b8c..dc8104ba00 100755 --- a/basis/db/sqlite/sqlite.factor +++ b/basis/db/sqlite/sqlite.factor @@ -1,13 +1,11 @@ ! Copyright (C) 2005, 2008 Chris Double, Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: alien arrays assocs classes compiler db -hashtables io.files kernel math math.parser namespaces -prettyprint sequences strings classes.tuple alien.c-types -continuations db.sqlite.lib db.sqlite.ffi db.tuples -words combinators.lib db.types combinators math.intervals -io namespaces.lib accessors vectors math.ranges random -math.bitfields.lib db.queries destructors ; -USE: tools.walker +USING: alien arrays assocs classes compiler db hashtables +io.files kernel math math.parser namespaces prettyprint +sequences strings classes.tuple alien.c-types continuations +db.sqlite.lib db.sqlite.ffi db.tuples words db.types combinators +math.intervals io nmake accessors vectors math.ranges random +math.bitwise db.queries destructors ; IN: db.sqlite TUPLE: sqlite-db < db path ; diff --git a/basis/db/tuples/tuples-tests.factor b/basis/db/tuples/tuples-tests.factor index 5dd3ec8ae0..3b04454995 100755 --- a/basis/db/tuples/tuples-tests.factor +++ b/basis/db/tuples/tuples-tests.factor @@ -3,8 +3,8 @@ USING: io.files kernel tools.test db db.tuples classes db.types continuations namespaces math math.ranges prettyprint calendar sequences db.sqlite math.intervals -db.postgresql accessors random math.bitfields.lib -math.ranges strings sequences.lib urls fry ; +db.postgresql accessors random math.bitwise +math.ranges strings urls fry ; IN: db.tuples.tests TUPLE: person the-id the-name the-number the-real diff --git a/basis/db/tuples/tuples.factor b/basis/db/tuples/tuples.factor index 1b7ab24366..437224ea5a 100755 --- a/basis/db/tuples/tuples.factor +++ b/basis/db/tuples/tuples.factor @@ -3,7 +3,7 @@ USING: arrays assocs classes db kernel namespaces classes.tuple words sequences slots math accessors math.parser io prettyprint db.types continuations -destructors mirrors sequences.lib combinators.lib ; +destructors mirrors ; IN: db.tuples : define-persistent ( class table columns -- ) @@ -71,13 +71,14 @@ SINGLETON: retryable ] 2map >>bind-params ; M: retryable execute-statement* ( statement type -- ) - drop [ + drop [ retries>> ] [ [ + nip [ query-results dispose t ] [ ] [ regenerate-params bind-statement* f ] cleanup ] curry - ] [ retries>> ] bi retry drop ; + ] bi attempt-all drop ; : resulting-tuple ( class row out-params -- tuple ) rot class new [ @@ -159,7 +160,8 @@ M: retryable execute-statement* ( statement type -- ) dup dup class do-select ; : select-tuple ( tuple -- tuple/f ) - dup dup class \ query new 1 >>limit do-select ?first ; + dup dup class \ query new 1 >>limit do-select + [ f ] [ first ] if-empty ; : do-count ( exemplar-tuple statement -- tuples ) [ diff --git a/basis/db/types/types.factor b/basis/db/types/types.factor index 2efa41c401..d3b99fcff3 100755 --- a/basis/db/types/types.factor +++ b/basis/db/types/types.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: arrays assocs db kernel math math.parser -sequences continuations sequences.deep sequences.lib +sequences continuations sequences.deep words namespaces slots slots.private classes mirrors classes.tuple combinators calendar.format symbols classes.singleton accessors quotations random ; diff --git a/basis/html/forms/forms.factor b/basis/html/forms/forms.factor index 0da3fcb0b3..911e545f87 100644 --- a/basis/html/forms/forms.factor +++ b/basis/html/forms/forms.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. USING: kernel accessors strings namespaces assocs hashtables -mirrors math fry sequences sequences.lib words continuations ; +mirrors math fry sequences words continuations ; IN: html.forms TUPLE: form errors values validation-failed ; diff --git a/basis/html/parser/analyzer/analyzer.factor b/basis/html/parser/analyzer/analyzer.factor deleted file mode 100755 index 29ccc345d3..0000000000 --- a/basis/html/parser/analyzer/analyzer.factor +++ /dev/null @@ -1,182 +0,0 @@ -USING: assocs html.parser kernel math sequences strings ascii -arrays generalizations shuffle unicode.case namespaces splitting -http sequences.lib accessors io combinators http.client urls ; -IN: html.parser.analyzer - -TUPLE: link attributes clickable ; - -: scrape-html ( url -- vector ) - http-get nip parse-html ; - -: (find-relative) - [ >r + dup r> ?nth* [ 2drop f f ] unless ] [ 2drop f ] if ; inline - -: find-relative ( seq quot n -- i elt ) - >r over [ find drop ] dip r> swap pick - (find-relative) ; inline - -: (find-all) ( n seq quot -- ) - 2dup >r >r find-from [ - dupd 2array , 1+ r> r> (find-all) - ] [ - r> r> 3drop - ] if* ; inline - -: find-all ( seq quot -- alist ) - [ 0 -rot (find-all) ] { } make ; inline - -: (find-nth) ( offset seq quot n count -- obj ) - >r >r [ find-from ] 2keep 4 npick [ - r> r> 1+ 2dup <= [ - 4drop - ] [ - >r >r >r >r drop 1+ r> r> r> r> - (find-nth) - ] if - ] [ - 2drop r> r> 2drop - ] if ; inline - -: find-nth ( seq quot n -- i elt ) - 0 -roll 0 (find-nth) ; inline - -: find-nth-relative ( seq quot n offest -- i elt ) - >r [ find-nth ] 3keep 2drop nip r> swap pick - (find-relative) ; inline - -: remove-blank-text ( vector -- vector' ) - [ - dup name>> text = [ - text>> [ blank? ] all? not - ] [ - drop t - ] if - ] filter ; - -: trim-text ( vector -- vector' ) - [ - dup name>> text = [ - [ [ blank? ] trim ] change-text - ] when - ] map ; - -: find-by-id ( id vector -- vector ) - [ attributes>> "id" swap at = ] with filter ; - -: find-by-class ( id vector -- vector ) - [ attributes>> "class" swap at = ] with filter ; - -: find-by-name ( str vector -- vector ) - >r >lower r> - [ name>> = ] with filter ; - -: find-first-name ( str vector -- i/f tag/f ) - >r >lower r> - [ name>> = ] with find ; - -: find-matching-close ( str vector -- i/f tag/f ) - >r >lower r> - [ [ name>> = ] keep closing?>> and ] with find ; - -: find-by-attribute-key ( key vector -- vector ) - >r >lower r> - [ attributes>> at ] with filter - sift ; - -: find-by-attribute-key-value ( value key vector -- vector ) - >r >lower r> - [ attributes>> at over = ] with filter nip - sift ; - -: find-first-attribute-key-value ( value key vector -- i/f tag/f ) - >r >lower r> - [ attributes>> at over = ] with find rot drop ; - -: find-between* ( i/f tag/f vector -- vector ) - pick integer? [ - rot tail-slice - >r name>> r> - [ find-matching-close drop dup [ 1+ ] when ] keep - swap [ head ] [ first ] if* - ] [ - 3drop V{ } clone - ] if ; - -: find-between ( i/f tag/f vector -- vector ) - find-between* dup length 3 >= [ - [ rest-slice but-last-slice ] keep like - ] when ; - -: find-between-first ( string vector -- vector' ) - [ find-first-name ] keep find-between ; - -: find-between-all ( vector quot -- seq ) - [ [ [ closing?>> not ] bi and ] curry find-all ] curry - [ [ >r first2 r> find-between* ] curry map ] bi ; - -: tag-link ( tag -- link/f ) - attributes>> [ "href" swap at ] [ f ] if* ; - -: find-links ( vector -- vector' ) - [ [ name>> "a" = ] [ attributes>> "href" swap at ] bi and ] - find-between-all ; - -: ( vector -- link ) - [ first attributes>> ] - [ [ name>> { text "img" } member? ] filter ] bi - link boa ; - -: link. ( vector -- ) - [ attributes>> "href" swap at write nl ] - [ clickable>> [ bl bl text>> print ] each nl ] bi ; - -: find-by-text ( seq quot -- tag ) - [ dup name>> text = ] prepose find drop ; - -: find-opening-tags-by-name ( name seq -- seq ) - [ [ name>> = ] keep closing?>> not and ] with find-all ; - -: href-contains? ( str tag -- ? ) - attributes>> "href" swap at* [ subseq? ] [ 2drop f ] if ; - -: find-hrefs ( vector -- vector' ) - find-links - [ [ - [ name>> "a" = ] - [ attributes>> "href" swap key? ] bi and ] filter - ] map sift [ [ attributes>> "href" swap at ] map ] map concat ; - -: find-forms ( vector -- vector' ) - "form" over find-opening-tags-by-name - swap [ >r first2 r> find-between* ] curry map - [ [ name>> { "form" "input" } member? ] filter ] map ; - -: find-html-objects ( string vector -- vector' ) - [ find-opening-tags-by-name ] keep - [ >r first2 r> find-between* ] curry map ; - -: form-action ( vector -- string ) - [ name>> "form" = ] find nip - attributes>> "action" swap at ; - -: hidden-form-values ( vector -- strings ) - [ attributes>> "type" swap at "hidden" = ] filter ; - -: input. ( tag -- ) - dup name>> print - attributes>> - [ bl bl bl bl [ write "=" write ] [ write bl ] bi* nl ] assoc-each ; - -: form. ( vector -- ) - [ closing?>> not ] filter - [ - { - { [ dup name>> "form" = ] - [ "form action: " write attributes>> "action" swap at print ] } - { [ dup name>> "input" = ] [ input. ] } - [ drop ] - } cond - ] each ; - -: query>assoc* ( str -- hash ) - "?" split1 nip query>assoc ; diff --git a/basis/html/parser/analyzer/authors.txt b/basis/html/parser/analyzer/authors.txt deleted file mode 100755 index 7c1b2f2279..0000000000 --- a/basis/html/parser/analyzer/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Doug Coleman diff --git a/basis/html/parser/authors.txt b/basis/html/parser/authors.txt deleted file mode 100755 index 7c1b2f2279..0000000000 --- a/basis/html/parser/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Doug Coleman diff --git a/basis/html/parser/parser-tests.factor b/basis/html/parser/parser-tests.factor deleted file mode 100644 index 9757f70a67..0000000000 --- a/basis/html/parser/parser-tests.factor +++ /dev/null @@ -1,62 +0,0 @@ -USING: html.parser kernel tools.test ; -IN: html.parser.tests - -[ - V{ T{ tag f "html" H{ } f f } } -] [ "" parse-html ] unit-test - -[ - V{ T{ tag f "html" H{ } f t } } -] [ "" parse-html ] unit-test - -[ - V{ T{ tag f "a" H{ { "href" "http://factorcode.org/" } } f f } } -] [ "" parse-html ] unit-test - -[ - V{ T{ tag f "a" H{ { "href" "http://factorcode.org/" } } f f } } -] [ "" parse-html ] unit-test - -[ -V{ - T{ - tag - f - "a" - H{ { "baz" "\"quux\"" } { "foo" "bar's" } } - f - f - } -} -] [ "" parse-html ] unit-test - -[ -V{ - T{ tag f "a" - H{ - { "a" "pirsqd" } - { "foo" "bar" } - { "href" "http://factorcode.org/" } - { "baz" "quux" } - } f f } -} -] [ "" parse-html ] unit-test - -[ -V{ - T{ tag f "html" H{ } f f } - T{ tag f "head" H{ } f f } - T{ tag f "head" H{ } f t } - T{ tag f "html" H{ } f t } -} -] [ "Spagna ( name attributes closing? -- tag ) - tag new - swap >>closing? - swap >>attributes - swap >>name ; - -: make-tag ( string attribs -- tag ) - >r [ closing-tag? ] keep "/" trim1 r> rot ; - -: make-text-tag ( string -- tag ) - tag new - text >>name - swap >>text ; - -: make-comment-tag ( string -- tag ) - tag new - comment >>name - swap >>text ; - -: make-dtd-tag ( string -- tag ) - tag new - dtd >>name - swap >>text ; - -: read-whitespace ( -- string ) - [ get-char blank? not ] take-until ; - -: read-whitespace* ( -- ) read-whitespace drop ; - -: read-token ( -- string ) - read-whitespace* - [ get-char blank? ] take-until ; - -: read-single-quote ( -- string ) - [ get-char CHAR: ' = ] take-until ; - -: read-double-quote ( -- string ) - [ get-char CHAR: " = ] take-until ; - -: read-quote ( -- string ) - get-char next* CHAR: ' = - [ read-single-quote ] [ read-double-quote ] if next* ; - -: read-key ( -- string ) - read-whitespace* - [ get-char [ CHAR: = = ] [ blank? ] bi or ] take-until ; - -: read-= ( -- ) - read-whitespace* - [ get-char CHAR: = = ] take-until drop next* ; - -: read-value ( -- string ) - read-whitespace* - get-char quote? [ read-quote ] [ read-token ] if - [ blank? ] trim ; - -: read-comment ( -- ) - "-->" take-string* make-comment-tag push-tag ; - -: read-dtd ( -- ) - ">" take-string* make-dtd-tag push-tag ; - -: read-bang ( -- ) - next* get-char CHAR: - = get-next CHAR: - = and [ - next* next* - read-comment - ] [ - read-dtd - ] if ; - -: read-tag ( -- string ) - [ get-char CHAR: > = get-char CHAR: < = or ] take-until - get-char CHAR: < = [ next* ] unless ; - -: read-< ( -- string ) - next* get-char CHAR: ! = [ - read-bang f - ] [ - read-tag - ] if ; - -: read-until-< ( -- string ) - [ get-char CHAR: < = ] take-until ; - -: parse-text ( -- ) - read-until-< dup empty? [ - drop - ] [ - make-text-tag push-tag - ] if ; - -: (parse-attributes) ( -- ) - read-whitespace* - string-parse-end? [ - read-key >lower read-= read-value - 2array , (parse-attributes) - ] unless ; - -: parse-attributes ( -- hashtable ) - [ (parse-attributes) ] { } make >hashtable ; - -: (parse-tag) ( string -- string' hashtable ) - [ - read-token >lower - parse-attributes - ] string-parse ; - -: parse-tag ( -- ) - read-< [ - (parse-tag) make-tag push-tag - ] unless-empty ; - -: (parse-html) ( -- ) - get-next [ - parse-text - parse-tag - (parse-html) - ] when ; - -: tag-parse ( quot -- vector ) - V{ } clone tagstack [ string-parse ] with-variable ; - -: parse-html ( string -- vector ) - [ (parse-html) tagstack get ] tag-parse ; diff --git a/basis/html/parser/printer/authors.txt b/basis/html/parser/printer/authors.txt deleted file mode 100755 index 7c1b2f2279..0000000000 --- a/basis/html/parser/printer/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Doug Coleman diff --git a/basis/html/parser/printer/printer.factor b/basis/html/parser/printer/printer.factor deleted file mode 100644 index 4419eec70e..0000000000 --- a/basis/html/parser/printer/printer.factor +++ /dev/null @@ -1,89 +0,0 @@ -USING: accessors assocs html.parser html.parser.utils combinators -continuations hashtables -hashtables.private io kernel math -namespaces prettyprint quotations sequences splitting -strings ; -IN: html.parser.printer - -SYMBOL: printer - -TUPLE: html-printer ; -TUPLE: text-printer < html-printer ; -TUPLE: src-printer < html-printer ; -TUPLE: html-prettyprinter < html-printer ; - -HOOK: print-text-tag html-printer ( tag -- ) -HOOK: print-comment-tag html-printer ( tag -- ) -HOOK: print-dtd-tag html-printer ( tag -- ) -HOOK: print-opening-tag html-printer ( tag -- ) -HOOK: print-closing-tag html-printer ( tag -- ) - -ERROR: unknown-tag-error tag ; - -: print-tag ( tag -- ) - { - { [ dup name>> text = ] [ print-text-tag ] } - { [ dup name>> comment = ] [ print-comment-tag ] } - { [ dup name>> dtd = ] [ print-dtd-tag ] } - { [ dup [ name>> string? ] [ closing?>> ] bi and ] - [ print-closing-tag ] } - { [ dup name>> string? ] - [ print-opening-tag ] } - [ unknown-tag-error ] - } cond ; - -: print-tags ( vector -- ) [ print-tag ] each ; - -: html-text. ( vector -- ) - T{ text-printer } html-printer [ print-tags ] with-variable ; - -: html-src. ( vector -- ) - T{ src-printer } html-printer [ print-tags ] with-variable ; - -M: html-printer print-text-tag ( tag -- ) text>> write ; - -M: html-printer print-comment-tag ( tag -- ) - "" write ; - -M: html-printer print-dtd-tag ( tag -- ) - "> write ">" write ; - -: print-attributes ( hashtable -- ) - [ [ bl write "=" write ] [ ?quote write ] bi* ] assoc-each ; - -M: src-printer print-opening-tag ( tag -- ) - "<" write - [ name>> write ] - [ attributes>> dup assoc-empty? [ drop ] [ print-attributes ] if ] bi - ">" write ; - -M: src-printer print-closing-tag ( tag -- ) - "> write - ">" write ; - -SYMBOL: tab-width -SYMBOL: #indentations -SYMBOL: tagstack - -: prettyprint-html ( vector -- ) - [ - T{ html-prettyprinter } printer set - V{ } clone tagstack set - 2 tab-width set - 0 #indentations set - print-tags - ] with-scope ; - -: print-tabs ( -- ) - tab-width get #indentations get * CHAR: \s write ; - -M: html-prettyprinter print-opening-tag ( tag -- ) - print-tabs "<" write - name>> write - ">\n" write ; - -M: html-prettyprinter print-closing-tag ( tag -- ) - "> write - ">" write ; diff --git a/basis/html/parser/utils/authors.txt b/basis/html/parser/utils/authors.txt deleted file mode 100755 index 7c1b2f2279..0000000000 --- a/basis/html/parser/utils/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Doug Coleman diff --git a/basis/html/parser/utils/utils-tests.factor b/basis/html/parser/utils/utils-tests.factor deleted file mode 100644 index 4b25db16fd..0000000000 --- a/basis/html/parser/utils/utils-tests.factor +++ /dev/null @@ -1,24 +0,0 @@ -USING: assocs combinators continuations hashtables -hashtables.private io kernel math -namespaces prettyprint quotations sequences splitting -state-parser strings tools.test ; -USING: html.parser.utils ; -IN: html.parser.utils.tests - -[ "'Rome'" ] [ "Rome" single-quote ] unit-test -[ "\"Roma\"" ] [ "Roma" double-quote ] unit-test -[ "'Firenze'" ] [ "Firenze" quote ] unit-test -[ "\"Caesar's\"" ] [ "Caesar's" quote ] unit-test -[ f ] [ "" quoted? ] unit-test -[ t ] [ "''" quoted? ] unit-test -[ t ] [ "\"\"" quoted? ] unit-test -[ t ] [ "\"Circus Maximus\"" quoted? ] unit-test -[ t ] [ "'Circus Maximus'" quoted? ] unit-test -[ f ] [ "Circus Maximus" quoted? ] unit-test -[ "'Italy'" ] [ "Italy" ?quote ] unit-test -[ "'Italy'" ] [ "'Italy'" ?quote ] unit-test -[ "\"Italy\"" ] [ "\"Italy\"" ?quote ] unit-test -[ "Italy" ] [ "Italy" unquote ] unit-test -[ "Italy" ] [ "'Italy'" unquote ] unit-test -[ "Italy" ] [ "\"Italy\"" unquote ] unit-test - diff --git a/basis/html/parser/utils/utils.factor b/basis/html/parser/utils/utils.factor deleted file mode 100644 index 04b3687f7d..0000000000 --- a/basis/html/parser/utils/utils.factor +++ /dev/null @@ -1,37 +0,0 @@ -USING: assocs circular combinators continuations hashtables -hashtables.private io kernel math -namespaces prettyprint quotations sequences splitting -state-parser strings sequences.lib ; -IN: html.parser.utils - -: string-parse-end? ( -- ? ) get-next not ; - -: take-string* ( match -- string ) - dup length - [ 2dup string-matches? ] take-until nip - dup length rot length 1- - head next* ; - -: trim1 ( seq ch -- newseq ) - [ ?head drop ] [ ?tail drop ] bi ; - -: single-quote ( str -- newstr ) - "'" swap "'" 3append ; - -: double-quote ( str -- newstr ) - "\"" swap "\"" 3append ; - -: quote ( str -- newstr ) - CHAR: ' over member? - [ double-quote ] [ single-quote ] if ; - -: quoted? ( str -- ? ) - [ f ] - [ [ first ] [ peek ] bi [ = ] keep "'\"" member? and ] if-empty ; - -: ?quote ( str -- newstr ) - dup quoted? [ quote ] unless ; - -: unquote ( str -- newstr ) - dup quoted? [ but-last-slice rest-slice >string ] when ; - -: quote? ( ch -- ? ) "'\"" member? ; diff --git a/basis/http/http.factor b/basis/http/http.factor index 2a5a19036f..e450631d94 100755 --- a/basis/http/http.factor +++ b/basis/http/http.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2003, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors kernel combinators math namespaces -assocs assocs.lib sequences splitting sorting sets debugger +assocs sequences splitting sorting sets debugger strings vectors hashtables quotations arrays byte-arrays math.parser calendar calendar.format present @@ -27,9 +27,12 @@ IN: http : (read-header) ( -- alist ) [ read-crlf dup f like ] [ parse-header-line ] [ drop ] produce ; +: collect-headers ( assoc -- assoc' ) + H{ } clone [ '[ , push-at ] assoc-each ] keep ; + : process-header ( alist -- assoc ) f swap [ [ swap or dup ] dip swap ] assoc-map nip - [ ?push ] histogram [ "; " join ] assoc-map + collect-headers [ "; " join ] assoc-map >hashtable ; : read-header ( -- assoc ) diff --git a/basis/io/unix/files/files.factor b/basis/io/unix/files/files.factor index 63712cd45c..c6eda50855 100755 --- a/basis/io/unix/files/files.factor +++ b/basis/io/unix/files/files.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: io.backend io.ports io.unix.backend io.files io unix unix.stat unix.time kernel math continuations -math.bitfields byte-arrays alien combinators calendar +math.bitwise byte-arrays alien combinators calendar io.encodings.binary accessors sequences strings system io.files.private destructors ; diff --git a/basis/io/unix/files/unique/unique.factor b/basis/io/unix/files/unique/unique.factor index dca2f51958..95e321fd93 100644 --- a/basis/io/unix/files/unique/unique.factor +++ b/basis/io/unix/files/unique/unique.factor @@ -1,4 +1,4 @@ -USING: kernel io.ports io.unix.backend math.bitfields +USING: kernel io.ports io.unix.backend math.bitwise unix io.files.unique.backend system ; IN: io.unix.files.unique diff --git a/basis/io/unix/kqueue/kqueue.factor b/basis/io/unix/kqueue/kqueue.factor index 8888d0182f..b3e69a453c 100755 --- a/basis/io/unix/kqueue/kqueue.factor +++ b/basis/io/unix/kqueue/kqueue.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.c-types kernel math math.bitfields namespaces +USING: alien.c-types kernel math math.bitwise namespaces locals accessors combinators threads vectors hashtables sequences assocs continuations sets unix unix.time unix.kqueue unix.process diff --git a/basis/io/unix/linux/monitors/monitors.factor b/basis/io/unix/linux/monitors/monitors.factor index 5a980266f1..ff23fba0c6 100644 --- a/basis/io/unix/linux/monitors/monitors.factor +++ b/basis/io/unix/linux/monitors/monitors.factor @@ -4,7 +4,7 @@ USING: kernel io.backend io.monitors io.monitors.recursive io.files io.buffers io.monitors io.ports io.timeouts io.unix.backend io.unix.select io.encodings.utf8 unix.linux.inotify assocs namespaces threads continuations init -math math.bitfields sets alien alien.strings alien.c-types +math math.bitwise sets alien alien.strings alien.c-types vocabs.loader accessors system hashtables destructors unix ; IN: io.unix.linux.monitors diff --git a/basis/io/unix/mmap/mmap.factor b/basis/io/unix/mmap/mmap.factor index c31e23849e..d5dcda9436 100755 --- a/basis/io/unix/mmap/mmap.factor +++ b/basis/io/unix/mmap/mmap.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2007 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: alien io io.files kernel math math.bitfields system unix +USING: alien io io.files kernel math math.bitwise system unix io.unix.backend io.ports io.mmap destructors locals accessors ; IN: io.unix.mmap diff --git a/basis/io/windows/files/files.factor b/basis/io/windows/files/files.factor index 1377f82ced..5698ab6cf2 100755 --- a/basis/io/windows/files/files.factor +++ b/basis/io/windows/files/files.factor @@ -4,8 +4,7 @@ USING: alien.c-types io.binary io.backend io.files io.buffers io.windows kernel math splitting windows windows.kernel32 windows.time calendar combinators math.functions sequences namespaces words symbols system -io.ports destructors accessors -math.bitfields math.bitfields.lib ; +io.ports destructors accessors math.bitwise ; IN: io.windows.files : open-file ( path access-mode create-mode flags -- handle ) diff --git a/basis/io/windows/mmap/mmap.factor b/basis/io/windows/mmap/mmap.factor index 660a4017be..e5b0d10f2f 100755 --- a/basis/io/windows/mmap/mmap.factor +++ b/basis/io/windows/mmap/mmap.factor @@ -1,6 +1,6 @@ USING: alien alien.c-types arrays destructors generic io.mmap io.ports io.windows io.windows.files io.windows.privileges -kernel libc math math.bitfields namespaces quotations sequences +kernel libc math math.bitwise namespaces quotations sequences windows windows.advapi32 windows.kernel32 io.backend system accessors locals ; IN: io.windows.mmap diff --git a/basis/io/windows/nt/monitors/monitors.factor b/basis/io/windows/nt/monitors/monitors.factor index fa4d19a46e..54cb3b1104 100755 --- a/basis/io/windows/nt/monitors/monitors.factor +++ b/basis/io/windows/nt/monitors/monitors.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.c-types libc destructors locals kernel math assocs namespaces continuations sequences hashtables -sorting arrays combinators math.bitfields strings system +sorting arrays combinators math.bitwise strings system accessors threads splitting io.backend io.windows io.windows.nt.backend io.windows.nt.files io.monitors io.ports io.buffers io.files io.timeouts io diff --git a/basis/io/windows/nt/pipes/pipes.factor b/basis/io/windows/nt/pipes/pipes.factor index dc0d7cf1e5..aa52152b75 100755 --- a/basis/io/windows/nt/pipes/pipes.factor +++ b/basis/io/windows/nt/pipes/pipes.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2007, 2008 Doug Coleman, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.c-types arrays destructors io io.windows libc -windows.types math.bitfields windows.kernel32 windows namespaces +windows.types math.bitwise windows.kernel32 windows namespaces kernel sequences windows.errors assocs math.parser system random combinators accessors io.pipes io.ports ; IN: io.windows.nt.pipes diff --git a/basis/io/windows/nt/privileges/privileges.factor b/basis/io/windows/nt/privileges/privileges.factor index 007d05f9af..8418d09a5e 100755 --- a/basis/io/windows/nt/privileges/privileges.factor +++ b/basis/io/windows/nt/privileges/privileges.factor @@ -1,6 +1,6 @@ USING: alien alien.c-types alien.syntax arrays continuations destructors generic io.mmap io.ports io.windows io.windows.files -kernel libc math math.bitfields namespaces quotations sequences windows +kernel libc math math.bitwise namespaces quotations sequences windows windows.advapi32 windows.kernel32 io.backend system accessors io.windows.privileges ; IN: io.windows.nt.privileges diff --git a/basis/io/windows/windows.factor b/basis/io/windows/windows.factor index a290821163..6f6c29fc55 100755 --- a/basis/io/windows/windows.factor +++ b/basis/io/windows/windows.factor @@ -5,7 +5,7 @@ io.buffers io.files io.ports io.sockets io.binary io.sockets io.timeouts windows.errors strings kernel math namespaces sequences windows windows.kernel32 windows.shell32 windows.types windows.winsock splitting -continuations math.bitfields system accessors ; +continuations math.bitwise system accessors ; IN: io.windows : set-inherit ( handle ? -- ) diff --git a/basis/lcs/lcs.factor b/basis/lcs/lcs.factor index 2fa0b6cc71..6f9ae3c883 100755 --- a/basis/lcs/lcs.factor +++ b/basis/lcs/lcs.factor @@ -1,6 +1,5 @@ USING: sequences kernel math locals math.order math.ranges -accessors combinators.lib arrays namespaces combinators -combinators.short-circuit ; +accessors arrays namespaces combinators combinators.short-circuit ; IN: lcs r dup word? [ swapd execute ] when r> shift bitor ; - -: bitfield ( values... bitspec -- n ) - 0 [ (bitfield) ] reduce ; - -: flags ( values -- n ) - 0 [ dup word? [ execute ] when bitor ] reduce ; - -GENERIC: (bitfield-quot) ( spec -- quot ) - -M: integer (bitfield-quot) ( spec -- quot ) - [ swapd shift bitor ] curry ; - -M: pair (bitfield-quot) ( spec -- quot ) - first2 over word? [ >r swapd execute r> ] [ ] ? - [ shift bitor ] append 2curry ; - -: bitfield-quot ( spec -- quot ) - [ (bitfield-quot) ] map [ 0 ] prefix concat ; - -\ bitfield [ bitfield-quot ] 1 define-transform - -\ flags [ - [ 0 , [ , \ bitor , ] each ] [ ] make -] 1 define-transform diff --git a/basis/math/bitfields/summary.txt b/basis/math/bitfields/summary.txt deleted file mode 100644 index d622f818fd..0000000000 --- a/basis/math/bitfields/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Domain-specific language for constructing integers diff --git a/basis/math/bitwise/authors.txt b/basis/math/bitwise/authors.txt new file mode 100644 index 0000000000..f372b574ae --- /dev/null +++ b/basis/math/bitwise/authors.txt @@ -0,0 +1,2 @@ +Slava Pestov +Doug Coleman diff --git a/basis/math/bitwise/bitwise-docs.factor b/basis/math/bitwise/bitwise-docs.factor new file mode 100644 index 0000000000..247523369b --- /dev/null +++ b/basis/math/bitwise/bitwise-docs.factor @@ -0,0 +1,50 @@ +USING: help.markup help.syntax math ; +IN: math.bitwise + +ARTICLE: "math-bitfields" "Constructing bit fields" +"Some applications, such as binary communication protocols and assemblers, need to construct integers from elaborate bit field specifications. Hand-coding this using " { $link shift } " and " { $link bitor } " results in repetitive code. A higher-level facility exists to factor out this repetition:" +{ $subsection bitfield } ; + +ABOUT: "math-bitfields" + +HELP: bitfield +{ $values { "values..." "a series of objects" } { "bitspec" "an array" } { "n" integer } } +{ $description "Constructs an integer from a series of values on the stack together with a bit field specifier, which is an array whose elements have one of the following shapes:" + { $list + { { $snippet "{ constant shift }" } " - the resulting bit field is bitwise or'd with " { $snippet "constant" } " shifted to the right by " { $snippet "shift" } " bits" } + { { $snippet "{ word shift }" } " - the resulting bit field is bitwise or'd with " { $snippet "word" } " applied to the top of the stack; the result is shifted to the right by " { $snippet "shift" } " bits" } + { { $snippet "shift" } " - the resulting bit field is bitwise or'd with the top of the stack; the result is shifted to the right by " { $snippet "shift" } " bits" } + } +"The bit field specifier is processed left to right, so stack values should be supplied in reverse order." } +{ $examples + "Consider the following specification:" + { $list + { "bits 0-10 are set to the value of " { $snippet "x" } } + { "bits 11-14 are set to the value of " { $snippet "y" } } + { "bit 15 is always on" } + { "bits 16-20 are set to the value of " { $snippet "fooify" } " applied to " { $snippet "z" } } + } + "Such a bit field construction can be specified with a word like the following:" + { $code + ": baz-bitfield ( x y z -- n )" + " {" + " { fooify 16 }" + " { 1 15 }" + " 11" + " 0" + " } ;" + } +} ; + +HELP: bits +{ $values { "m" integer } { "n" integer } { "m'" integer } } +{ $description "Keep only n bits from the integer m." } +{ $example "USING: math.bitwise prettyprint ;" "HEX: 123abcdef 16 bits .h" "cdef" } ; + +HELP: bitroll +{ $values { "x" "an integer (input)" } { "s" "an integer (shift)" } { "w" "an integer (wrap)" } { "y" integer } } +{ $description "Roll n by s bits to the left, wrapping around after w bits." } +{ $examples + { $example "USING: math.bitwise prettyprint ;" "1 -1 32 bitroll .b" "10000000000000000000000000000000" } + { $example "USING: math.bitwise prettyprint ;" "HEX: ffff0000 8 32 bitroll .h" "ff0000ff" } +} ; diff --git a/basis/math/bitwise/bitwise-tests.factor b/basis/math/bitwise/bitwise-tests.factor new file mode 100755 index 0000000000..8b13cb23b3 --- /dev/null +++ b/basis/math/bitwise/bitwise-tests.factor @@ -0,0 +1,29 @@ +USING: accessors math math.bitwise tools.test kernel words ; +IN: math.bitwise.tests + +[ 0 ] [ 1 0 0 bitroll ] unit-test +[ 1 ] [ 1 0 1 bitroll ] unit-test +[ 1 ] [ 1 1 1 bitroll ] unit-test +[ 1 ] [ 1 0 2 bitroll ] unit-test +[ 1 ] [ 1 0 1 bitroll ] unit-test +[ 1 ] [ 1 20 2 bitroll ] unit-test +[ 1 ] [ 1 8 8 bitroll ] unit-test +[ 1 ] [ 1 -8 8 bitroll ] unit-test +[ 1 ] [ 1 -32 8 bitroll ] unit-test +[ 128 ] [ 1 -1 8 bitroll ] unit-test +[ 8 ] [ 1 3 32 bitroll ] unit-test + +[ 0 ] [ { } bitfield ] unit-test +[ 256 ] [ 1 { 8 } bitfield ] unit-test +[ 268 ] [ 3 1 { 8 2 } bitfield ] unit-test +[ 268 ] [ 1 { 8 { 3 2 } } bitfield ] unit-test +[ 512 ] [ 1 { { 1+ 8 } } bitfield ] unit-test + +: a 1 ; inline +: b 2 ; inline + +: foo ( -- flags ) { a b } flags ; + +[ 3 ] [ foo ] unit-test +[ 3 ] [ { a b } flags ] unit-test +\ foo must-infer diff --git a/basis/math/bitwise/bitwise.factor b/basis/math/bitwise/bitwise.factor new file mode 100644 index 0000000000..60c585c779 --- /dev/null +++ b/basis/math/bitwise/bitwise.factor @@ -0,0 +1,94 @@ +! Copyright (C) 2007, 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: arrays kernel math math.functions sequences +sequences.private words namespaces macros hints +combinators fry ; +IN: math.bitwise + +! utilities +: clear-bit ( x n -- y ) 2^ bitnot bitand ; inline +: set-bit ( x n -- y ) 2^ bitor ; inline +: bit-clear? ( x n -- ? ) 2^ bitand zero? ; inline +: unmask ( x n -- ? ) bitnot bitand ; inline +: unmask? ( x n -- ? ) unmask 0 > ; inline +: mask ( x n -- ? ) bitand ; inline +: mask? ( x n -- ? ) mask 0 > ; inline +: wrap ( m n -- m' ) 1- bitand ; inline +: bits ( m n -- m' ) 2^ wrap ; inline +: mask-bit ( m n -- m' ) 1- 2^ mask ; inline + +: shift-mod ( n s w -- n ) + >r shift r> 2^ wrap ; inline + +: bitroll ( x s w -- y ) + [ wrap ] keep + [ shift-mod ] + [ [ - ] keep shift-mod ] 3bi bitor ; inline + +: bitroll-32 ( n s -- n' ) 32 bitroll ; + +HINTS: bitroll-32 bignum fixnum ; + +: bitroll-64 ( n s -- n' ) 64 bitroll ; + +HINTS: bitroll-64 bignum fixnum ; + +! 32-bit arithmetic +: w+ ( int int -- int ) + 32 bits ; inline +: w- ( int int -- int ) - 32 bits ; inline +: w* ( int int -- int ) * 32 bits ; inline + +! flags +MACRO: flags ( values -- ) + [ 0 ] [ [ execute bitor ] curry compose ] reduce ; + +! bitfield +r swapd execute r> ] [ ] ? + [ shift bitor ] append 2curry ; + +PRIVATE> + +MACRO: bitfield ( bitspec -- ) + [ 0 ] [ (bitfield-quot) compose ] reduce ; + +! bit-count +> + +GENERIC: (bit-count) ( x -- n ) + +M: fixnum (bit-count) + { + [ byte-bit-count ] + [ -8 shift byte-bit-count ] + [ -16 shift byte-bit-count ] + [ -24 shift byte-bit-count ] + } cleave + + + ; + +M: bignum (bit-count) + dup 0 = [ drop 0 ] [ + [ byte-bit-count ] [ -8 shift (bit-count) ] bi + + ] if ; + +PRIVATE> + +: bit-count ( x -- n ) + dup 0 >= [ (bit-count) ] [ bitnot (bit-count) ] if ; inline diff --git a/basis/math/bitwise/summary.txt b/basis/math/bitwise/summary.txt new file mode 100644 index 0000000000..23f73db76c --- /dev/null +++ b/basis/math/bitwise/summary.txt @@ -0,0 +1 @@ +Bitwise arithmetic utilities diff --git a/basis/nmake/nmake-tests.factor b/basis/nmake/nmake-tests.factor new file mode 100644 index 0000000000..a6b1afb297 --- /dev/null +++ b/basis/nmake/nmake-tests.factor @@ -0,0 +1,8 @@ +IN: nmake.tests +USING: nmake kernel tools.test ; + +[ ] [ [ ] { } nmake ] unit-test + +[ { 1 } { 2 } ] [ [ 1 0, 2 1, ] { { } { } } nmake ] unit-test + +[ [ ] [ call ] curry { { } } nmake ] must-infer diff --git a/basis/nmake/nmake.factor b/basis/nmake/nmake.factor new file mode 100644 index 0000000000..80c3ce3411 --- /dev/null +++ b/basis/nmake/nmake.factor @@ -0,0 +1,44 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: namespaces sequences math.parser kernel macros +generalizations locals ; +IN: nmake + +SYMBOL: building-seq +: get-building-seq ( n -- seq ) + building-seq get nth ; + +: n, ( obj n -- ) get-building-seq push ; +: n% ( seq n -- ) get-building-seq push-all ; +: n# ( num n -- ) >r number>string r> n% ; + +: 0, ( obj -- ) 0 n, ; +: 0% ( seq -- ) 0 n% ; +: 0# ( num -- ) 0 n# ; +: 1, ( obj -- ) 1 n, ; +: 1% ( seq -- ) 1 n% ; +: 1# ( num -- ) 1 n# ; +: 2, ( obj -- ) 2 n, ; +: 2% ( seq -- ) 2 n% ; +: 2# ( num -- ) 2 n# ; +: 3, ( obj -- ) 3 n, ; +: 3% ( seq -- ) 3 n% ; +: 3# ( num -- ) 3 n# ; +: 4, ( obj -- ) 4 n, ; +: 4% ( seq -- ) 4 n% ; +: 4# ( num -- ) 4 n# ; + +MACRO: finish-nmake ( exemplars -- ) + length [ firstn ] curry ; + +:: nmake ( quot exemplars -- ) + [ + exemplars + [ 0 swap new-resizable ] map + building-seq set + + quot call + + building-seq get + exemplars [ [ like ] 2map ] [ finish-nmake ] bi + ] with-scope ; inline diff --git a/basis/opengl/capabilities/authors.txt b/basis/opengl/capabilities/authors.txt deleted file mode 100644 index 6a0dc7293a..0000000000 --- a/basis/opengl/capabilities/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Joe Groff \ No newline at end of file diff --git a/basis/opengl/capabilities/capabilities-docs.factor b/basis/opengl/capabilities/capabilities-docs.factor deleted file mode 100644 index f5424e19da..0000000000 --- a/basis/opengl/capabilities/capabilities-docs.factor +++ /dev/null @@ -1,59 +0,0 @@ -USING: help.markup help.syntax io kernel math quotations -opengl.gl multiline assocs ; -IN: opengl.capabilities - -HELP: gl-version -{ $values { "version" "The version string from the OpenGL implementation" } } -{ $description "Wrapper for " { $snippet "GL_VERSION glGetString" } " that removes the vendor-specific information from the version string." } ; - -HELP: gl-vendor-version -{ $values { "version" "The vendor-specific version information from the OpenGL implementation" } } -{ $description "Wrapper for " { $snippet "GL_VERSION glGetString" } " that returns only the vendor-specific information from the version string." } ; - -HELP: has-gl-version? -{ $values { "version" "A version string" } { "?" "A boolean value" } } -{ $description "Compares the version string returned by " { $link gl-version } " to " { $snippet "version" } ". Returns true if the implementation version meets or exceeds " { $snippet "version" } "." } ; - -HELP: require-gl-version -{ $values { "version" "A version string" } } -{ $description "Throws an exception if " { $link has-gl-version? } " returns false for " { $snippet "version" } "." } ; - -HELP: glsl-version -{ $values { "version" "The GLSL version string from the OpenGL implementation" } } -{ $description "Wrapper for " { $snippet "GL_SHADING_LANGUAGE_VERSION glGetString" } " that removes the vendor-specific information from the version string." } ; - -HELP: glsl-vendor-version -{ $values { "version" "The vendor-specific GLSL version information from the OpenGL implementation" } } -{ $description "Wrapper for " { $snippet "GL_SHADING_LANGUAGE_VERSION glGetString" } " that returns only the vendor-specific information from the version string." } ; - -HELP: has-glsl-version? -{ $values { "version" "A version string" } { "?" "A boolean value" } } -{ $description "Compares the version string returned by " { $link glsl-version } " to " { $snippet "version" } ". Returns true if the implementation version meets or exceeds " { $snippet "version" } "." } ; - -HELP: require-glsl-version -{ $values { "version" "A version string" } } -{ $description "Throws an exception if " { $link has-glsl-version? } " returns false for " { $snippet "version" } "." } ; - -HELP: gl-extensions -{ $values { "seq" "A sequence of strings naming the implementation-supported OpenGL extensions" } } -{ $description "Wrapper for " { $snippet "GL_EXTENSIONS glGetString" } " that returns a sequence of extension names supported by the OpenGL implementation." } ; - -HELP: has-gl-extensions? -{ $values { "extensions" "A sequence of extension name strings" } { "?" "A boolean value" } } -{ $description "Returns true if the set of " { $snippet "extensions" } " is a subset of the implementation-supported extensions returned by " { $link gl-extensions } "." } ; - -HELP: has-gl-version-or-extensions? -{ $values { "version" "A version string" } { "extensions" "A sequence of extension name strings" } { "?" "a boolean" } } -{ $description "Returns true if either " { $link has-gl-version? } " or " { $link has-gl-extensions? } " returns true for " { $snippet "version" } " or " { $snippet "extensions" } ", respectively. Intended for use when required OpenGL functionality can be verified either by a minimum version or a set of equivalent extensions." } ; - -HELP: require-gl-extensions -{ $values { "extensions" "A sequence of extension name strings" } } -{ $description "Throws an exception if " { $link has-gl-extensions? } " returns false for " { $snippet "extensions" } "." } ; - -HELP: require-gl-version-or-extensions -{ $values { "version" "A version string" } { "extensions" "A sequence of extension name strings" } } -{ $description "Throws an exception if neither " { $link has-gl-version? } " nor " { $link has-gl-extensions? } " returns true for " { $snippet "version" } " or " { $snippet "extensions" } ", respectively. Intended for use when required OpenGL functionality can be verified either by a minimum version or a set of equivalent extensions." } ; - -{ require-gl-version require-glsl-version require-gl-extensions require-gl-version-or-extensions has-gl-version? has-glsl-version? has-gl-extensions? has-gl-version-or-extensions? gl-version glsl-version gl-extensions } related-words - -ABOUT: "gl-utilities" diff --git a/basis/opengl/capabilities/capabilities.factor b/basis/opengl/capabilities/capabilities.factor deleted file mode 100755 index 806935d5c9..0000000000 --- a/basis/opengl/capabilities/capabilities.factor +++ /dev/null @@ -1,67 +0,0 @@ -! Copyright (C) 2008 Joe Groff. -! See http://factorcode.org/license.txt for BSD license. -USING: kernel namespaces sequences splitting opengl.gl -continuations math.parser math arrays sets math.order ; -IN: opengl.capabilities - -: (require-gl) ( thing require-quot make-error-quot -- ) - -rot dupd call - [ 2drop ] - [ swap " " make throw ] - if ; inline - -: gl-extensions ( -- seq ) - GL_EXTENSIONS glGetString " " split ; -: has-gl-extensions? ( extensions -- ? ) - gl-extensions swap [ over member? ] all? nip ; -: (make-gl-extensions-error) ( required-extensions -- ) - gl-extensions diff - "Required OpenGL extensions not supported:\n" % - [ " " % % "\n" % ] each ; -: require-gl-extensions ( extensions -- ) - [ has-gl-extensions? ] - [ (make-gl-extensions-error) ] - (require-gl) ; - -: version-seq ( version-string -- version-seq ) - "." split [ string>number ] map ; - -: version-before? ( version1 version2 -- ? ) - swap version-seq swap version-seq before=? ; - -: (gl-version) ( -- version vendor ) - GL_VERSION glGetString " " split1 ; -: gl-version ( -- version ) - (gl-version) drop ; -: gl-vendor-version ( -- version ) - (gl-version) nip ; -: has-gl-version? ( version -- ? ) - gl-version version-before? ; -: (make-gl-version-error) ( required-version -- ) - "Required OpenGL version " % % " not supported (" % gl-version % " available)" % ; -: require-gl-version ( version -- ) - [ has-gl-version? ] - [ (make-gl-version-error) ] - (require-gl) ; - -: (glsl-version) ( -- version vendor ) - GL_SHADING_LANGUAGE_VERSION glGetString " " split1 ; -: glsl-version ( -- version ) - (glsl-version) drop ; -: glsl-vendor-version ( -- version ) - (glsl-version) nip ; -: has-glsl-version? ( version -- ? ) - glsl-version version-before? ; -: require-glsl-version ( version -- ) - [ has-glsl-version? ] - [ "Required GLSL version " % % " not supported (" % glsl-version % " available)" % ] - (require-gl) ; - -: has-gl-version-or-extensions? ( version extensions -- ? ) - has-gl-extensions? swap has-gl-version? or ; - -: require-gl-version-or-extensions ( version extensions -- ) - 2array [ first2 has-gl-version-or-extensions? ] [ - dup first (make-gl-version-error) "\n" % - second (make-gl-extensions-error) "\n" % - ] (require-gl) ; diff --git a/basis/opengl/capabilities/summary.txt b/basis/opengl/capabilities/summary.txt deleted file mode 100644 index d31b63b8d4..0000000000 --- a/basis/opengl/capabilities/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Testing for OpenGL versions and extensions \ No newline at end of file diff --git a/basis/opengl/capabilities/tags.txt b/basis/opengl/capabilities/tags.txt deleted file mode 100644 index 77282be3a9..0000000000 --- a/basis/opengl/capabilities/tags.txt +++ /dev/null @@ -1,2 +0,0 @@ -opengl -bindings diff --git a/basis/opengl/demo-support/authors.txt b/basis/opengl/demo-support/authors.txt deleted file mode 100644 index 6a0dc7293a..0000000000 --- a/basis/opengl/demo-support/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Joe Groff \ No newline at end of file diff --git a/basis/opengl/demo-support/demo-support.factor b/basis/opengl/demo-support/demo-support.factor deleted file mode 100755 index 2bf2abae95..0000000000 --- a/basis/opengl/demo-support/demo-support.factor +++ /dev/null @@ -1,89 +0,0 @@ -USING: arrays kernel math math.functions -math.order math.vectors namespaces opengl opengl.gl sequences ui -ui.gadgets ui.gestures ui.render accessors ; -IN: opengl.demo-support - -: FOV 2.0 sqrt 1+ ; inline -: MOUSE-MOTION-SCALE 0.5 ; inline -: KEY-ROTATE-STEP 1.0 ; inline - -SYMBOL: last-drag-loc - -TUPLE: demo-gadget < gadget yaw pitch distance ; - -: new-demo-gadget ( yaw pitch distance class -- gadget ) - new-gadget - swap >>distance - swap >>pitch - swap >>yaw ; - -GENERIC: far-plane ( gadget -- z ) -GENERIC: near-plane ( gadget -- z ) -GENERIC: distance-step ( gadget -- dz ) - -M: demo-gadget far-plane ( gadget -- z ) - drop 4.0 ; -M: demo-gadget near-plane ( gadget -- z ) - drop 1.0 64.0 / ; -M: demo-gadget distance-step ( gadget -- dz ) - drop 1.0 64.0 / ; - -: fov-ratio ( gadget -- fov ) dim>> dup first2 min v/n ; - -: yaw-demo-gadget ( yaw gadget -- ) - [ + ] with change-yaw relayout-1 ; - -: pitch-demo-gadget ( pitch gadget -- ) - [ + ] with change-pitch relayout-1 ; - -: zoom-demo-gadget ( distance gadget -- ) - [ + ] with change-distance relayout-1 ; - -M: demo-gadget pref-dim* ( gadget -- dim ) - drop { 640 480 } ; - -: -+ ( x -- -x x ) - [ neg ] keep ; - -: demo-gadget-frustum ( gadget -- -x x -y y near far ) - [ near-plane ] [ far-plane ] [ fov-ratio ] tri [ - nip swap FOV / v*n - first2 [ -+ ] bi@ - ] 3keep drop ; - -: demo-gadget-set-matrices ( gadget -- ) - GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT bitor glClear - [ - GL_PROJECTION glMatrixMode - glLoadIdentity - demo-gadget-frustum glFrustum - ] [ - GL_MODELVIEW glMatrixMode - glLoadIdentity - [ >r 0.0 0.0 r> distance>> neg glTranslatef ] - [ pitch>> 1.0 0.0 0.0 glRotatef ] - [ yaw>> 0.0 1.0 0.0 glRotatef ] - tri - ] bi ; - -: reset-last-drag-rel ( -- ) - { 0 0 } last-drag-loc set-global ; -: last-drag-rel ( -- rel ) - drag-loc [ last-drag-loc get v- ] keep last-drag-loc set-global ; - -: drag-yaw-pitch ( -- yaw pitch ) - last-drag-rel MOUSE-MOTION-SCALE v*n first2 ; - -demo-gadget H{ - { T{ key-down f f "LEFT" } [ KEY-ROTATE-STEP neg swap yaw-demo-gadget ] } - { T{ key-down f f "RIGHT" } [ KEY-ROTATE-STEP swap yaw-demo-gadget ] } - { T{ key-down f f "DOWN" } [ KEY-ROTATE-STEP neg swap pitch-demo-gadget ] } - { T{ key-down f f "UP" } [ KEY-ROTATE-STEP swap pitch-demo-gadget ] } - { T{ key-down f f "=" } [ dup distance-step neg swap zoom-demo-gadget ] } - { T{ key-down f f "-" } [ dup distance-step swap zoom-demo-gadget ] } - - { T{ button-down f f 1 } [ drop reset-last-drag-rel ] } - { T{ drag f 1 } [ drag-yaw-pitch rot [ pitch-demo-gadget ] keep yaw-demo-gadget ] } - { T{ mouse-scroll } [ scroll-direction get second over distance-step * swap zoom-demo-gadget ] } -} set-gestures - diff --git a/basis/opengl/demo-support/summary.txt b/basis/opengl/demo-support/summary.txt deleted file mode 100644 index eca681450f..0000000000 --- a/basis/opengl/demo-support/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Common support for OpenGL demos \ No newline at end of file diff --git a/basis/opengl/demo-support/tags.txt b/basis/opengl/demo-support/tags.txt deleted file mode 100644 index a6797bf627..0000000000 --- a/basis/opengl/demo-support/tags.txt +++ /dev/null @@ -1 +0,0 @@ -opengl diff --git a/basis/opengl/framebuffers/authors.txt b/basis/opengl/framebuffers/authors.txt deleted file mode 100644 index 6a0dc7293a..0000000000 --- a/basis/opengl/framebuffers/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Joe Groff \ No newline at end of file diff --git a/basis/opengl/framebuffers/framebuffers-docs.factor b/basis/opengl/framebuffers/framebuffers-docs.factor deleted file mode 100644 index c5507dcce1..0000000000 --- a/basis/opengl/framebuffers/framebuffers-docs.factor +++ /dev/null @@ -1,35 +0,0 @@ -USING: help.markup help.syntax io kernel math quotations -opengl.gl multiline assocs ; -IN: opengl.framebuffers - -HELP: gen-framebuffer -{ $values { "id" integer } } -{ $description "Wrapper for " { $link glGenFramebuffersEXT } " to handle the common case of generating a single framebuffer ID." } ; - -HELP: gen-renderbuffer -{ $values { "id" integer } } -{ $description "Wrapper for " { $link glGenRenderbuffersEXT } " to handle the common case of generating a single render buffer ID." } ; - -HELP: delete-framebuffer -{ $values { "id" integer } } -{ $description "Wrapper for " { $link glDeleteFramebuffersEXT } " to handle the common case of deleting a single framebuffer ID." } ; - -HELP: delete-renderbuffer -{ $values { "id" integer } } -{ $description "Wrapper for " { $link glDeleteRenderbuffersEXT } " to handle the common case of deleting a single render buffer ID." } ; - -{ gen-framebuffer delete-framebuffer } related-words -{ gen-renderbuffer delete-renderbuffer } related-words - -HELP: framebuffer-incomplete? -{ $values { "status/f" "The framebuffer error code, or " { $snippet "f" } " if the framebuffer is render-complete." } } -{ $description "Checks the framebuffer currently bound by " { $link glBindFramebufferEXT } " or " { $link with-framebuffer } " to see if it is incomplete, i.e., it is not ready to be rendered to." } ; - -HELP: check-framebuffer -{ $description "Checks the framebuffer currently bound by " { $link glBindFramebufferEXT } " or " { $link with-framebuffer } " with " { $link framebuffer-incomplete? } ", and throws a descriptive error if the framebuffer is incomplete." } ; - -HELP: with-framebuffer -{ $values { "id" "The id of a framebuffer object." } { "quot" "a quotation" } } -{ $description "Binds framebuffer " { $snippet "id" } " in the dynamic extent of " { $snippet "quot" } ", restoring the window framebuffer when finished." } ; - -ABOUT: "gl-utilities" \ No newline at end of file diff --git a/basis/opengl/framebuffers/framebuffers.factor b/basis/opengl/framebuffers/framebuffers.factor deleted file mode 100644 index 346789e1c5..0000000000 --- a/basis/opengl/framebuffers/framebuffers.factor +++ /dev/null @@ -1,43 +0,0 @@ -! Copyright (C) 2008 Joe Groff. -! See http://factorcode.org/license.txt for BSD license. -USING: opengl opengl.gl combinators continuations kernel -alien.c-types ; -IN: opengl.framebuffers - -: gen-framebuffer ( -- id ) - [ glGenFramebuffersEXT ] (gen-gl-object) ; -: gen-renderbuffer ( -- id ) - [ glGenRenderbuffersEXT ] (gen-gl-object) ; - -: delete-framebuffer ( id -- ) - [ glDeleteFramebuffersEXT ] (delete-gl-object) ; -: delete-renderbuffer ( id -- ) - [ glDeleteRenderbuffersEXT ] (delete-gl-object) ; - -: framebuffer-incomplete? ( -- status/f ) - GL_FRAMEBUFFER_EXT glCheckFramebufferStatusEXT - dup GL_FRAMEBUFFER_COMPLETE_EXT = f rot ? ; - -: framebuffer-error ( status -- * ) - { - { GL_FRAMEBUFFER_COMPLETE_EXT [ "framebuffer complete" ] } - { GL_FRAMEBUFFER_UNSUPPORTED_EXT [ "framebuffer configuration unsupported" ] } - { GL_FRAMEBUFFER_INCOMPLETE_ATTACHMENT_EXT [ "framebuffer incomplete (incomplete attachment)" ] } - { GL_FRAMEBUFFER_INCOMPLETE_MISSING_ATTACHMENT_EXT [ "framebuffer incomplete (missing attachment)" ] } - { GL_FRAMEBUFFER_INCOMPLETE_DIMENSIONS_EXT [ "framebuffer incomplete (dimension mismatch)" ] } - { GL_FRAMEBUFFER_INCOMPLETE_FORMATS_EXT [ "framebuffer incomplete (format mismatch)" ] } - { GL_FRAMEBUFFER_INCOMPLETE_DRAW_BUFFER_EXT [ "framebuffer incomplete (draw buffer(s) have no attachment)" ] } - { GL_FRAMEBUFFER_INCOMPLETE_READ_BUFFER_EXT [ "framebuffer incomplete (read buffer has no attachment)" ] } - [ drop gl-error "unknown framebuffer error" ] - } case throw ; - -: check-framebuffer ( -- ) - framebuffer-incomplete? [ framebuffer-error ] when* ; - -: with-framebuffer ( id quot -- ) - GL_FRAMEBUFFER_EXT rot glBindFramebufferEXT - [ GL_FRAMEBUFFER_EXT 0 glBindFramebufferEXT ] [ ] cleanup ; inline - -: framebuffer-attachment ( attachment -- id ) - GL_FRAMEBUFFER_EXT swap GL_FRAMEBUFFER_ATTACHMENT_OBJECT_NAME_EXT - 0 [ glGetFramebufferAttachmentParameterivEXT ] keep *uint ; diff --git a/basis/opengl/framebuffers/summary.txt b/basis/opengl/framebuffers/summary.txt deleted file mode 100644 index 3ef713ac13..0000000000 --- a/basis/opengl/framebuffers/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Rendering to offscreen textures using the GL_EXT_framebuffer_object extension \ No newline at end of file diff --git a/basis/opengl/framebuffers/tags.txt b/basis/opengl/framebuffers/tags.txt deleted file mode 100644 index 77282be3a9..0000000000 --- a/basis/opengl/framebuffers/tags.txt +++ /dev/null @@ -1,2 +0,0 @@ -opengl -bindings diff --git a/basis/opengl/gadgets/gadgets-tests.factor b/basis/opengl/gadgets/gadgets-tests.factor deleted file mode 100644 index 499ec9730a..0000000000 --- a/basis/opengl/gadgets/gadgets-tests.factor +++ /dev/null @@ -1,4 +0,0 @@ -IN: opengl.gadgets.tests -USING: tools.test opengl.gadgets ; - -\ render* must-infer diff --git a/basis/opengl/gadgets/gadgets.factor b/basis/opengl/gadgets/gadgets.factor deleted file mode 100644 index 9e670c04ab..0000000000 --- a/basis/opengl/gadgets/gadgets.factor +++ /dev/null @@ -1,112 +0,0 @@ -! Copyright (C) 2008 Matthew Willis. -! See http://factorcode.org/license.txt for BSD license. -USING: locals math.functions math namespaces -opengl.gl accessors kernel opengl ui.gadgets -fry assocs -destructors sequences ui.render colors ; -IN: opengl.gadgets - -TUPLE: texture-gadget ; - -GENERIC: render* ( gadget -- texture dims ) -GENERIC: cache-key* ( gadget -- key ) - -M: texture-gadget cache-key* ; - -SYMBOL: textures -SYMBOL: refcounts - -: init-cache ( symbol -- ) - dup get [ drop ] [ H{ } clone swap set-global ] if ; - -textures init-cache -refcounts init-cache - -: refcount-change ( gadget quot -- ) - >r cache-key* refcounts get - [ [ 0 ] unless* ] r> compose change-at ; - -TUPLE: cache-entry tex dims ; -C: cache-entry - -: make-entry ( gadget -- entry ) - dup render* - [ swap cache-key* textures get set-at ] keep ; - -: get-entry ( gadget -- {texture,dims} ) - dup cache-key* textures get at - [ nip ] [ make-entry ] if* ; - -: get-dims ( gadget -- dims ) - get-entry dims>> ; - -: get-texture ( gadget -- texture ) - get-entry tex>> ; - -: release-texture ( gadget -- ) - cache-key* textures get delete-at* - [ tex>> delete-texture ] [ drop ] if ; - -M: texture-gadget graft* ( gadget -- ) [ 1+ ] refcount-change ; - -M: texture-gadget ungraft* ( gadget -- ) - dup [ 1- ] refcount-change - dup cache-key* refcounts get at - zero? [ release-texture ] [ drop ] if ; - -: 2^-ceil ( x -- y ) - dup 2 < [ 2 * ] [ 1- log2 1+ 2^ ] if ; foldable flushable - -: 2^-bounds ( dim -- dim' ) - [ 2^-ceil ] map ; foldable flushable - -:: (render-bytes) ( dims bytes format texture -- ) - GL_ENABLE_BIT [ - GL_TEXTURE_2D glEnable - GL_TEXTURE_2D texture glBindTexture - GL_TEXTURE_2D - 0 - GL_RGBA - dims 2^-bounds first2 - 0 - format - GL_UNSIGNED_BYTE - bytes - glTexImage2D - init-texture - GL_TEXTURE_2D 0 glBindTexture - ] do-attribs ; - -: render-bytes ( dims bytes format -- texture ) - gen-texture [ (render-bytes) ] keep ; - -: render-bytes* ( dims bytes format -- texture dims ) - pick >r render-bytes r> ; - -:: four-corners ( dim -- ) - [let* | w [ dim first ] - h [ dim second ] - dim' [ dim dup 2^-bounds [ /f ] 2map ] - w' [ dim' first ] - h' [ dim' second ] | - 0 0 glTexCoord2d 0 0 glVertex2d - 0 h' glTexCoord2d 0 h glVertex2d - w' h' glTexCoord2d w h glVertex2d - w' 0 glTexCoord2d w 0 glVertex2d - ] ; - -M: texture-gadget draw-gadget* ( gadget -- ) - origin get [ - GL_ENABLE_BIT [ - white gl-color - 1.0 -1.0 glPixelZoom - GL_TEXTURE_2D glEnable - GL_TEXTURE_2D over get-texture glBindTexture - GL_QUADS [ - get-dims four-corners - ] do-state - GL_TEXTURE_2D 0 glBindTexture - ] do-attribs - ] with-translation ; - -M: texture-gadget pref-dim* ( gadget -- dim ) get-dims ; diff --git a/basis/opengl/shaders/authors.txt b/basis/opengl/shaders/authors.txt deleted file mode 100644 index 6a0dc7293a..0000000000 --- a/basis/opengl/shaders/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Joe Groff \ No newline at end of file diff --git a/basis/opengl/shaders/shaders-docs.factor b/basis/opengl/shaders/shaders-docs.factor deleted file mode 100644 index 1a10071ddf..0000000000 --- a/basis/opengl/shaders/shaders-docs.factor +++ /dev/null @@ -1,101 +0,0 @@ -USING: help.markup help.syntax io kernel math quotations -opengl.gl multiline assocs strings ; -IN: opengl.shaders - -HELP: gl-shader -{ $class-description { $snippet "gl-shader" } " is a predicate class comprising values returned by OpenGL to represent shader objects. The following words are provided for creating and manipulating these objects:" - { $list - { { $link } " - Compile GLSL code into a shader object" } - { { $link gl-shader-ok? } " - Check whether a shader object compiled successfully" } - { { $link check-gl-shader } " - Throw an error unless a shader object compiled successfully" } - { { $link gl-shader-info-log } " - Retrieve the info log of messages generated by the GLSL compiler" } - { { $link delete-gl-shader } " - Invalidate a shader object" } - } - "The derived predicate classes " { $link vertex-shader } " and " { $link fragment-shader } " are also defined for the two standard kinds of shader defined by the OpenGL specification." } ; - -HELP: vertex-shader -{ $class-description { $snippet "vertex-shader" } " is the predicate class of " { $link gl-shader } " objects that refer to shaders of type " { $snippet "GL_VERTEX_SHADER" } ". In addition to the " { $snippet "gl-shader" } " words, the following vertex shader-specific functions are defined:" - { $list - { { $link } " - Compile GLSL code into a vertex shader object "} - } -} ; - -HELP: fragment-shader -{ $class-description { $snippet "fragment-shader" } " is the predicate class of " { $link gl-shader } " objects that refer to shaders of type " { $snippet "GL_FRAGMENT_SHADER" } ". In addition to the " { $snippet "gl-shader" } " words, the following fragment shader-specific functions are defined:" - { $list - { { $link } " - Compile GLSL code into a fragment shader object "} - } -} ; - -HELP: -{ $values { "source" "The GLSL source code to compile" } { "kind" "The kind of shader to compile, such as " { $snippet "GL_VERTEX_SHADER" } " or " { $snippet "GL_FRAGMENT_SHADER" } } { "shader" "a new " { $link gl-shader } } } -{ $description "Tries to compile the given GLSL source into a shader object. The returned object can be checked for validity by " { $link check-gl-shader } " or " { $link gl-shader-ok? } ". Errors and warnings generated by the GLSL compiler will be collected in the info log, available from " { $link gl-shader-info-log } ".\n\nWhen the shader object is no longer needed, it should be deleted using " { $link delete-gl-shader } " or else be attached to a " { $link gl-program } " object deleted using " { $link delete-gl-program } "." } ; - -HELP: -{ $values { "source" "The GLSL source code to compile" } { "vertex-shader" "a new " { $link vertex-shader } } } -{ $description "Tries to compile the given GLSL source into a vertex shader object. Equivalent to " { $snippet "GL_VERTEX_SHADER " } "." } ; - -HELP: -{ $values { "source" "The GLSL source code to compile" } { "fragment-shader" "a new " { $link fragment-shader } } } -{ $description "Tries to compile the given GLSL source into a fragment shader object. Equivalent to " { $snippet "GL_FRAGMENT_SHADER " } "." } ; - -HELP: gl-shader-ok? -{ $values { "shader" "A " { $link gl-shader } " object" } { "?" "a boolean" } } -{ $description "Returns a boolean value indicating whether the given shader object compiled successfully. Compilation errors and warnings are available in the shader's info log, which can be gotten using " { $link gl-shader-info-log } "." } ; - -HELP: check-gl-shader -{ $values { "shader" "A " { $link gl-shader } " object" } } -{ $description "Throws an error containing the " { $link gl-shader-info-log } " for the shader object if it failed to compile. Otherwise, the shader object is left on the stack." } ; - -HELP: delete-gl-shader -{ $values { "shader" "A " { $link gl-shader } " object" } } -{ $description "Deletes the shader object, invalidating it and releasing any resources allocated for it by the OpenGL implementation." } ; - -HELP: gl-shader-info-log -{ $values { "shader" "A " { $link gl-shader } " object" } { "shader" "a new " { $link gl-shader } } { "log" string } } -{ $description "Retrieves the info log for " { $snippet "shader" } ", including any errors or warnings generated in compiling the shader object." } ; - -HELP: gl-program -{ $class-description { $snippet "gl-program" } " is a predicate class comprising values returned by OpenGL to represent proram objects. The following words are provided for creating and manipulating these objects:" - { $list - { { $link } ", " { $link } " - Link a set of shaders into a GLSL program" } - { { $link gl-program-ok? } " - Check whether a program object linked successfully" } - { { $link check-gl-program } " - Throw an error unless a program object linked successfully" } - { { $link gl-program-info-log } " - Retrieve the info log of messages generated by the GLSL linker" } - { { $link gl-program-shaders } " - Retrieve the set of shader objects composing the GLSL program" } - { { $link delete-gl-program } " - Invalidate a program object and all its attached shaders" } - { { $link with-gl-program } " - Use a program object" } - } -} ; - -HELP: -{ $values { "shaders" "A sequence of " { $link gl-shader } " objects." } { "program" "a new " { $link gl-program } } } -{ $description "Creates a new GLSL program object, attaches all the shader objects in the " { $snippet "shaders" } " sequence, and attempts to link them. The returned object can be checked for validity by " { $link check-gl-program } " or " { $link gl-program-ok? } ". Errors and warnings generated by the GLSL linker will be collected in the info log, available from " { $link gl-program-info-log } ".\n\nWhen the program object and its attached shaders are no longer needed, it should be deleted using " { $link delete-gl-program } "." } ; - -HELP: -{ $values { "vertex-shader-source" "A string containing GLSL vertex shader source" } { "fragment-shader-source" "A string containing GLSL fragment shader source" } { "program" "a new " { $link gl-program } } } -{ $description "Wrapper for " { $link } " for the simple case of compiling a single vertex shader and fragment shader and linking them into a GLSL program. Throws an exception if compiling or linking fails." } ; - -{ } related-words - -HELP: gl-program-ok? -{ $values { "program" "A " { $link gl-program } " object" } { "?" "a boolean" } } -{ $description "Returns a boolean value indicating whether the given program object linked successfully. Link errors and warnings are available in the program's info log, which can be gotten using " { $link gl-program-info-log } "." } ; - -HELP: check-gl-program -{ $values { "program" "A " { $link gl-program } " object" } } -{ $description "Throws an error containing the " { $link gl-program-info-log } " for the program object if it failed to link. Otherwise, the program object is left on the stack." } ; - -HELP: gl-program-info-log -{ $values { "program" "A " { $link gl-program } " object" } { "log" string } } -{ $description "Retrieves the info log for " { $snippet "program" } ", including any errors or warnings generated in linking the program object." } ; - -HELP: delete-gl-program -{ $values { "program" "A " { $link gl-program } " object" } } -{ $description "Deletes the program object, invalidating it and releasing any resources allocated for it by the OpenGL implementation. Any attached " { $link gl-shader } "s are also deleted.\n\nIf the shader objects should be preserved, they should each be detached using " { $link detach-gl-program-shader } ". The program object can then be destroyed alone using " { $link delete-gl-program-only } "." } ; - -HELP: with-gl-program -{ $values { "program" "A " { $link gl-program } " object" } { "quot" "A quotation with stack effect " { $snippet "( program -- )" } } } -{ $description "Enables " { $snippet "program" } " for all OpenGL calls made in the dynamic extent of " { $snippet "quot" } ". " { $snippet "program" } " is left on the top of the stack when " { $snippet "quot" } " is called. The fixed-function pipeline is restored at the end of " { $snippet "quot" } "." } ; - -ABOUT: "gl-utilities" diff --git a/basis/opengl/shaders/shaders.factor b/basis/opengl/shaders/shaders.factor deleted file mode 100755 index d52e55417f..0000000000 --- a/basis/opengl/shaders/shaders.factor +++ /dev/null @@ -1,119 +0,0 @@ -! Copyright (C) 2008 Joe Groff. -! See http://factorcode.org/license.txt for BSD license. -USING: kernel opengl.gl alien.c-types continuations namespaces -assocs alien alien.strings libc opengl math sequences combinators -combinators.lib macros arrays io.encodings.ascii fry ; -IN: opengl.shaders - -: with-gl-shader-source-ptr ( string quot -- ) - swap ascii malloc-string [ swap call ] keep free ; inline - -: ( source kind -- shader ) - glCreateShader dup rot - [ 1 swap f glShaderSource ] with-gl-shader-source-ptr - [ glCompileShader ] keep - gl-error ; - -: (gl-shader?) ( object -- ? ) - dup integer? [ glIsShader c-bool> ] [ drop f ] if ; - -: gl-shader-get-int ( shader enum -- value ) - 0 [ glGetShaderiv ] keep *int ; - -: gl-shader-ok? ( shader -- ? ) - GL_COMPILE_STATUS gl-shader-get-int c-bool> ; - -: ( source -- vertex-shader ) - GL_VERTEX_SHADER ; inline - -: (vertex-shader?) ( object -- ? ) - dup (gl-shader?) - [ GL_SHADER_TYPE gl-shader-get-int GL_VERTEX_SHADER = ] - [ drop f ] if ; - -: ( source -- fragment-shader ) - GL_FRAGMENT_SHADER ; inline - -: (fragment-shader?) ( object -- ? ) - dup (gl-shader?) - [ GL_SHADER_TYPE gl-shader-get-int GL_FRAGMENT_SHADER = ] - [ drop f ] if ; - -: gl-shader-info-log-length ( shader -- log-length ) - GL_INFO_LOG_LENGTH gl-shader-get-int ; inline - -: gl-shader-info-log ( shader -- log ) - dup gl-shader-info-log-length dup [ - [ 0 swap glGetShaderInfoLog ] keep - ascii alien>string - ] with-malloc ; - -: check-gl-shader ( shader -- shader ) - dup gl-shader-ok? [ dup gl-shader-info-log throw ] unless ; - -: delete-gl-shader ( shader -- ) glDeleteShader ; inline - -PREDICATE: gl-shader < integer (gl-shader?) ; -PREDICATE: vertex-shader < gl-shader (vertex-shader?) ; -PREDICATE: fragment-shader < gl-shader (fragment-shader?) ; - -! Programs - -: ( shaders -- program ) - glCreateProgram swap - [ dupd glAttachShader ] each - [ glLinkProgram ] keep - gl-error ; - -: (gl-program?) ( object -- ? ) - dup integer? [ glIsProgram c-bool> ] [ drop f ] if ; - -: gl-program-get-int ( program enum -- value ) - 0 [ glGetProgramiv ] keep *int ; - -: gl-program-ok? ( program -- ? ) - GL_LINK_STATUS gl-program-get-int c-bool> ; - -: gl-program-info-log-length ( program -- log-length ) - GL_INFO_LOG_LENGTH gl-program-get-int ; inline - -: gl-program-info-log ( program -- log ) - dup gl-program-info-log-length dup [ - [ 0 swap glGetProgramInfoLog ] keep - ascii alien>string - ] with-malloc ; - -: check-gl-program ( program -- program ) - dup gl-program-ok? [ dup gl-program-info-log throw ] unless ; - -: gl-program-shaders-length ( program -- shaders-length ) - GL_ATTACHED_SHADERS gl-program-get-int ; inline - -: gl-program-shaders ( program -- shaders ) - dup gl-program-shaders-length - dup "GLuint" - 0 swap - [ glGetAttachedShaders ] { 3 1 } multikeep - c-uint-array> ; - -: delete-gl-program-only ( program -- ) - glDeleteProgram ; inline - -: detach-gl-program-shader ( program shader -- ) - glDetachShader ; inline - -: delete-gl-program ( program -- ) - dup gl-program-shaders [ - 2dup detach-gl-program-shader delete-gl-shader - ] each delete-gl-program-only ; - -: with-gl-program ( program quot -- ) - over glUseProgram [ 0 glUseProgram ] [ ] cleanup ; inline - -PREDICATE: gl-program < integer (gl-program?) ; - -: ( vertex-shader-source fragment-shader-source -- program ) - >r check-gl-shader - r> check-gl-shader - 2array check-gl-program ; - diff --git a/basis/opengl/shaders/summary.txt b/basis/opengl/shaders/summary.txt deleted file mode 100644 index c55f76668f..0000000000 --- a/basis/opengl/shaders/summary.txt +++ /dev/null @@ -1 +0,0 @@ -OpenGL Shading Language (GLSL) support \ No newline at end of file diff --git a/basis/opengl/shaders/tags.txt b/basis/opengl/shaders/tags.txt deleted file mode 100644 index ce0345edc9..0000000000 --- a/basis/opengl/shaders/tags.txt +++ /dev/null @@ -1,3 +0,0 @@ -opengl -glsl -bindings \ No newline at end of file diff --git a/basis/openssl/libssl/libssl.factor b/basis/openssl/libssl/libssl.factor index e951ad8858..f1dc21f993 100755 --- a/basis/openssl/libssl/libssl.factor +++ b/basis/openssl/libssl/libssl.factor @@ -2,7 +2,7 @@ ! Portions copyright (C) 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.syntax combinators kernel system namespaces -assocs parser lexer sequences words quotations math.bitfields ; +assocs parser lexer sequences words quotations math.bitwise ; IN: openssl.libssl diff --git a/basis/peg/ebnf/ebnf.factor b/basis/peg/ebnf/ebnf.factor index 6e9d78e649..7083262c49 100644 --- a/basis/peg/ebnf/ebnf.factor +++ b/basis/peg/ebnf/ebnf.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel compiler.units words arrays strings math.parser sequences quotations vectors namespaces math assocs continuations peg - peg.parsers unicode.categories multiline combinators.lib + peg.parsers unicode.categories multiline splitting accessors effects sequences.deep peg.search combinators.short-circuit lexer io.streams.string stack-checker io prettyprint combinators parser ; diff --git a/basis/peg/search/authors.txt b/basis/peg/search/authors.txt new file mode 100644 index 0000000000..44b06f94bc --- /dev/null +++ b/basis/peg/search/authors.txt @@ -0,0 +1 @@ +Chris Double diff --git a/basis/peg/search/search-docs.factor b/basis/peg/search/search-docs.factor new file mode 100755 index 0000000000..565601ea11 --- /dev/null +++ b/basis/peg/search/search-docs.factor @@ -0,0 +1,44 @@ +! Copyright (C) 2006 Chris Double. +! See http://factorcode.org/license.txt for BSD license. +USING: help.syntax help.markup peg ; +IN: peg.search + +HELP: tree-write +{ $values + { "object" "an object" } } +{ $description + "Write the object to the standard output stream, unless " + "it is an array, in which case recurse through the array " + "writing each object to the stream." } +{ $example "USE: peg.search" "{ 65 \"bc\" { 68 \"ef\" } } tree-write" "AbcDef" } ; + +HELP: search +{ $values + { "string" "a string" } + { "parser" "a peg based parser" } + { "seq" "a sequence" } +} +{ $description + "Returns a sequence containing the parse results of all substrings " + "from the input string that successfully parse using the " + "parser." +} + +{ $example "USING: peg.parsers peg.search prettyprint ;" "\"one 123 two 456\" 'integer' search ." "V{ 123 456 }" } +{ $example "USING: peg peg.parsers peg.search prettyprint ;" "\"one 123 \\\"hello\\\" two 456\" 'integer' 'string' 2choice search ." "V{ 123 \"hello\" 456 }" } +{ $see-also replace } ; + +HELP: replace +{ $values + { "string" "a string" } + { "parser" "a peg based parser" } + { "result" "a string" } +} +{ $description + "Returns a copy of the original string but with all substrings that " + "successfully parse with the given parser replaced with " + "the result of that parser." +} +{ $example "USING: math math.parser peg peg.parsers peg.search prettyprint ;" "\"one 123 two 456\" 'integer' [ 2 * number>string ] action replace ." "\"one 246 two 912\"" } +{ $see-also search } ; + diff --git a/basis/peg/search/search-tests.factor b/basis/peg/search/search-tests.factor new file mode 100755 index 0000000000..b22a5ef0d0 --- /dev/null +++ b/basis/peg/search/search-tests.factor @@ -0,0 +1,19 @@ +! Copyright (C) 2007 Chris Double. +! See http://factorcode.org/license.txt for BSD license. +! +USING: kernel math math.parser arrays tools.test peg peg.parsers +peg.search ; +IN: peg.search.tests + +{ V{ 123 456 } } [ + "abc 123 def 456" 'integer' search +] unit-test + +{ V{ 123 "hello" 456 } } [ + "one 123 \"hello\" two 456" 'integer' 'string' 2array choice search +] unit-test + +{ "abc 246 def 912" } [ + "abc 123 def 456" 'integer' [ 2 * number>string ] action replace +] unit-test + diff --git a/basis/peg/search/search.factor b/basis/peg/search/search.factor new file mode 100755 index 0000000000..04e4affe39 --- /dev/null +++ b/basis/peg/search/search.factor @@ -0,0 +1,29 @@ +! Copyright (C) 2006 Chris Double. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel math io io.streams.string sequences strings +combinators peg memoize arrays continuations ; +IN: peg.search + +: tree-write ( object -- ) + { + { [ dup number? ] [ write1 ] } + { [ dup string? ] [ write ] } + { [ dup sequence? ] [ [ tree-write ] each ] } + { [ t ] [ write ] } + } cond ; + +MEMO: any-char-parser ( -- parser ) + [ drop t ] satisfy ; + +: search ( string parser -- seq ) + any-char-parser [ drop f ] action 2array choice repeat0 + [ parse sift ] [ 3drop { } ] recover ; + + +: (replace) ( string parser -- seq ) + any-char-parser 2array choice repeat0 parse sift ; + +: replace ( string parser -- result ) + [ (replace) [ tree-write ] each ] with-string-writer ; + + diff --git a/basis/peg/search/summary.txt b/basis/peg/search/summary.txt new file mode 100644 index 0000000000..ad27ade319 --- /dev/null +++ b/basis/peg/search/summary.txt @@ -0,0 +1 @@ +Search and replace using parsing expression grammars diff --git a/basis/peg/search/tags.txt b/basis/peg/search/tags.txt new file mode 100644 index 0000000000..9da56880c0 --- /dev/null +++ b/basis/peg/search/tags.txt @@ -0,0 +1 @@ +parsing diff --git a/basis/persistent/hashtables/nodes/bitmap/bitmap.factor b/basis/persistent/hashtables/nodes/bitmap/bitmap.factor index 7fb14a4541..f231043274 100644 --- a/basis/persistent/hashtables/nodes/bitmap/bitmap.factor +++ b/basis/persistent/hashtables/nodes/bitmap/bitmap.factor @@ -1,7 +1,7 @@ ! Based on Clojure's PersistentHashMap by Rich Hickey. -USING: math math.bit-count arrays kernel accessors locals sequences -sequences.private sequences.lib +USING: math math.bitwise arrays kernel accessors locals sequences +sequences.private persistent.sequences persistent.hashtables.config persistent.hashtables.nodes ; diff --git a/basis/persistent/hashtables/nodes/collision/collision.factor b/basis/persistent/hashtables/nodes/collision/collision.factor index b74a2ed45d..83003e5c47 100644 --- a/basis/persistent/hashtables/nodes/collision/collision.factor +++ b/basis/persistent/hashtables/nodes/collision/collision.factor @@ -1,6 +1,6 @@ ! Based on Clojure's PersistentHashMap by Rich Hickey. -USING: kernel accessors math arrays fry sequences sequences.lib +USING: kernel accessors math arrays fry sequences locals persistent.sequences persistent.hashtables.config persistent.hashtables.nodes diff --git a/basis/persistent/hashtables/nodes/full/full.factor b/basis/persistent/hashtables/nodes/full/full.factor index e0fcc1a0ab..5c60c91dca 100644 --- a/basis/persistent/hashtables/nodes/full/full.factor +++ b/basis/persistent/hashtables/nodes/full/full.factor @@ -1,7 +1,7 @@ ! Based on Clojure's PersistentHashMap by Rich Hickey. USING: math accessors kernel arrays sequences sequences.private -locals sequences.lib +locals persistent.sequences persistent.hashtables.config persistent.hashtables.nodes ; diff --git a/basis/persistent/hashtables/nodes/nodes.factor b/basis/persistent/hashtables/nodes/nodes.factor index 6201e68c6a..d681cd57fa 100644 --- a/basis/persistent/hashtables/nodes/nodes.factor +++ b/basis/persistent/hashtables/nodes/nodes.factor @@ -1,6 +1,6 @@ ! Based on Clojure's PersistentHashMap by Rich Hickey. -USING: math arrays kernel sequences sequences.lib +USING: math arrays kernel sequences accessors locals persistent.hashtables.config ; IN: persistent.hashtables.nodes diff --git a/basis/random/mersenne-twister/mersenne-twister.factor b/basis/random/mersenne-twister/mersenne-twister.factor index 01e79abff2..0a730190c2 100755 --- a/basis/random/mersenne-twister/mersenne-twister.factor +++ b/basis/random/mersenne-twister/mersenne-twister.factor @@ -3,7 +3,7 @@ ! mersenne twister based on ! http://www.math.sci.hiroshima-u.ac.jp/~m-mat/MT/MT2002/CODES/mt19937ar.c USING: arrays kernel math namespaces sequences system init -accessors math.ranges random circular math.bitfields.lib +accessors math.ranges random circular math.bitwise combinators ; IN: random.mersenne-twister diff --git a/basis/random/random-tests.factor b/basis/random/random-tests.factor index d85df3e0be..eed4bf2e13 100644 --- a/basis/random/random-tests.factor +++ b/basis/random/random-tests.factor @@ -1,4 +1,4 @@ -USING: random sequences tools.test ; +USING: random sequences tools.test kernel ; IN: random.tests [ 4 ] [ 4 random-bytes length ] unit-test @@ -6,3 +6,6 @@ IN: random.tests [ 4 ] [ [ 4 random-bytes length ] with-secure-random ] unit-test [ 7 ] [ [ 7 random-bytes length ] with-secure-random ] unit-test + +[ 2 ] [ V{ 10 20 30 } [ delete-random drop ] keep length ] unit-test +[ V{ } [ delete-random drop ] keep length ] must-fail diff --git a/basis/random/random.factor b/basis/random/random.factor index 74b7a78723..d37e2fc2b7 100755 --- a/basis/random/random.factor +++ b/basis/random/random.factor @@ -43,6 +43,9 @@ M: f random-32* ( obj -- * ) no-random-number-generator ; ] keep nth ] if ; +: delete-random ( seq -- elt ) + [ length random ] keep [ nth ] 2keep delete-nth ; + : random-bits ( n -- r ) 2^ random ; : with-random ( tuple quot -- ) diff --git a/basis/smtp/smtp.factor b/basis/smtp/smtp.factor index 5df4b80614..fa98c7a947 100755 --- a/basis/smtp/smtp.factor +++ b/basis/smtp/smtp.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2007, 2008 Elie CHAFTARI, Dirk Vleugels, ! Slava Pestov, Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays namespaces io io.timeouts kernel logging io.sockets -sequences combinators sequences.lib splitting assocs strings +USING: arrays namespaces io io.timeouts kernel logging +io.sockets sequences combinators splitting assocs strings math.parser random system calendar io.encodings.ascii summary calendar.format accessors sets hashtables ; IN: smtp @@ -112,7 +112,7 @@ ERROR: smtp-transaction-failed < smtp-error ; } cond ; : multiline? ( response -- boolean ) - ?fourth CHAR: - = ; + 3 swap ?nth CHAR: - = ; : process-multiline ( multiline -- response ) >r readln r> 2dup " " append head? [ @@ -184,21 +184,3 @@ PRIVATE> : send-email ( email -- ) [ email>headers ] keep (send-email) ; - -! Dirk's old AUTH CRAM-MD5 code. I don't know anything about -! CRAM MD5, and the old code didn't work properly either, so here -! it is in case anyone wants to fix it later. -! -! check-response used to have this clause: -! { [ dup "334" head? ] [ " " split 1 swap nth base64> challenge set ] } -! -! and the rest of the code was as follows: -! : (cram-md5-auth) ( -- response ) -! swap challenge get -! string>md5-hmac hex-string -! " " prepend append -! >base64 ; -! -! : cram-md5-auth ( key login -- ) -! "AUTH CRAM-MD5\r\n" get-ok -! (cram-md5-auth) "\r\n" append get-ok ; diff --git a/basis/state-parser/state-parser.factor b/basis/state-parser/state-parser.factor index ee5a5113bf..15c83bf73a 100644 --- a/basis/state-parser/state-parser.factor +++ b/basis/state-parser/state-parser.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: io io.streams.string kernel math namespaces sequences strings circular prettyprint debugger ascii sbufs fry summary -accessors sequences.lib ; +accessors ; IN: state-parser ! * Basic underlying words @@ -120,7 +120,7 @@ M: not-enough-characters summary ( obj -- str ) : take ( n -- string ) [ 1- ] [ ] bi [ - '[ drop get-char [ next , push f ] [ t ] if* ] attempt-each drop + '[ drop get-char [ next , push f ] [ t ] if* ] contains? drop ] keep get-char [ over push ] when* >string ; : pass-blank ( -- ) diff --git a/basis/tools/scaffold/scaffold.factor b/basis/tools/scaffold/scaffold.factor index 69eac5dc15..1312681f85 100644 --- a/basis/tools/scaffold/scaffold.factor +++ b/basis/tools/scaffold/scaffold.factor @@ -3,8 +3,8 @@ USING: assocs io.files hashtables kernel namespaces sequences vocabs.loader io combinators io.encodings.utf8 calendar accessors math.parser io.streams.string ui.tools.operations quotations -strings arrays prettyprint words vocabs sorting sets cords -classes sequences.lib combinators.lib ; +strings arrays prettyprint words vocabs sorting sets +classes ; IN: tools.scaffold SYMBOL: developer-name @@ -160,16 +160,18 @@ ERROR: no-vocab vocab ; : help-file-string ( str1 -- str2 ) [ - [ "IN: " write print nl ] - [ interesting-words. ] - [ "ARTICLE: " write unparse dup write bl print ";" print nl ] - [ "ABOUT: " write unparse print ] quad + { + [ "IN: " write print nl ] + [ interesting-words. ] + [ "ARTICLE: " write unparse dup write bl print ";" print nl ] + [ "ABOUT: " write unparse print ] + } cleave ] with-string-writer ; : write-using ( -- ) "USING:" write using get keys - { "help.markup" "help.syntax" } cord-append natural-sort + { "help.markup" "help.syntax" } append natural-sort [ bl write ] each " ;" print ; diff --git a/basis/ui/gadgets/canvas/canvas.factor b/basis/ui/gadgets/canvas/canvas.factor index 85149f4551..4ff7519a85 100755 --- a/basis/ui/gadgets/canvas/canvas.factor +++ b/basis/ui/gadgets/canvas/canvas.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: ui.backend ui.gadgets ui.gadgets.theme ui.gadgets.lib +USING: ui.backend ui.gadgets ui.gadgets.theme ui.gadgets.worlds ui.render opengl opengl.gl kernel namespaces classes.tuple colors accessors ; IN: ui.gadgets.canvas diff --git a/basis/ui/gadgets/cartesian/cartesian.factor b/basis/ui/gadgets/cartesian/cartesian.factor deleted file mode 100644 index 730b0f5b44..0000000000 --- a/basis/ui/gadgets/cartesian/cartesian.factor +++ /dev/null @@ -1,42 +0,0 @@ - -USING: kernel combinators sequences opengl.gl - ui.render ui.gadgets ui.gadgets.slate - accessors ; - -IN: ui.gadgets.cartesian - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -TUPLE: cartesian < slate x-min x-max y-min y-max z-min z-max perspective ; - -: init-cartesian ( cartesian -- cartesian ) - init-slate - -10 >>x-min - 10 >>x-max - -10 >>y-min - 10 >>y-max - -1 >>z-min - 1 >>z-max ; - -: ( -- cartesian ) cartesian new init-cartesian ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -M: cartesian establish-coordinate-system ( cartesian -- cartesian ) - dup - { - [ x-min>> ] [ x-max>> ] - [ y-min>> ] [ y-max>> ] - [ z-min>> ] [ z-max>> ] - } - cleave - glOrtho ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: x-range ( cartesian range -- cartesian ) first2 [ >>x-min ] [ >>x-max ] bi* ; -: y-range ( cartesian range -- cartesian ) first2 [ >>y-min ] [ >>y-max ] bi* ; -: z-range ( cartesian range -- cartesian ) first2 [ >>z-min ] [ >>z-max ] bi* ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - diff --git a/basis/ui/gadgets/frame-buffer/frame-buffer.factor b/basis/ui/gadgets/frame-buffer/frame-buffer.factor deleted file mode 100644 index 2d58037982..0000000000 --- a/basis/ui/gadgets/frame-buffer/frame-buffer.factor +++ /dev/null @@ -1,115 +0,0 @@ - -USING: kernel alien.c-types combinators sequences splitting grouping - opengl.gl ui.gadgets ui.render - math math.vectors accessors math.geometry.rect ; - -IN: ui.gadgets.frame-buffer - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -TUPLE: frame-buffer < gadget action pdim last-dim graft ungraft pixels ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: init-frame-buffer-pixels ( frame-buffer -- frame-buffer ) - dup - rect-dim product "uint[4]" - >>pixels ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: new-frame-buffer ( class -- gadget ) - new-gadget - [ ] >>action - { 100 100 } >>pdim - [ ] >>graft - [ ] >>ungraft ; - -: ( -- frame-buffer ) frame-buffer new-frame-buffer ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: draw-pixels ( fb -- fb ) - dup >r - dup >r - rect-dim first2 GL_RGBA GL_UNSIGNED_INT r> pixels>> glDrawPixels - r> ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: read-pixels ( fb -- fb ) - dup >r - dup >r - >r - 0 0 r> rect-dim first2 GL_RGBA GL_UNSIGNED_INT r> pixels>> glReadPixels - r> ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -M: frame-buffer pref-dim* pdim>> ; -M: frame-buffer graft* graft>> call ; -M: frame-buffer ungraft* ungraft>> call ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: copy-row ( old new -- ) - 2dup min-length swap >r head-slice 0 r> copy ; - -! : copy-pixels ( old-pixels old-width new-pixels new-width -- ) -! [ group ] 2bi@ -! [ copy-row ] 2each ; - -! : copy-pixels ( old-pixels old-width new-pixels new-width -- ) -! [ 16 * group ] 2bi@ -! [ copy-row ] 2each ; - -: copy-pixels ( old-pixels old-width new-pixels new-width -- ) - [ 16 * ] 2bi@ - [ copy-row ] 2each ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -M: frame-buffer layout* ( fb -- ) - { - { - [ dup last-dim>> f = ] - [ - init-frame-buffer-pixels - dup - rect-dim >>last-dim - drop - ] - } - { - [ dup [ rect-dim ] [ last-dim>> ] bi = not ] - [ - dup [ pixels>> ] [ last-dim>> first ] bi - - rot init-frame-buffer-pixels - dup rect-dim >>last-dim - - [ pixels>> ] [ rect-dim first ] bi - - copy-pixels - ] - } - { [ t ] [ drop ] } - } - cond ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -M: frame-buffer draw-gadget* ( fb -- ) - - dup rect-dim { 0 1 } v* first2 glRasterPos2i - - draw-pixels - - dup action>> call - - glFlush - - read-pixels - - drop ; - diff --git a/basis/ui/gadgets/handler/authors.txt b/basis/ui/gadgets/handler/authors.txt deleted file mode 100755 index 6cfd5da273..0000000000 --- a/basis/ui/gadgets/handler/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Eduardo Cavazos diff --git a/basis/ui/gadgets/handler/handler.factor b/basis/ui/gadgets/handler/handler.factor deleted file mode 100644 index 1c12142593..0000000000 --- a/basis/ui/gadgets/handler/handler.factor +++ /dev/null @@ -1,11 +0,0 @@ - -USING: kernel assocs ui.gestures ui.gadgets.wrappers accessors ; - -IN: ui.gadgets.handler - -TUPLE: handler < wrapper table ; - -: ( child -- handler ) handler new-wrapper ; - -M: handler handle-gesture ( gesture gadget -- ? ) - tuck table>> at dup [ call f ] [ 2drop t ] if ; \ No newline at end of file diff --git a/basis/ui/gadgets/lib/authors.txt b/basis/ui/gadgets/lib/authors.txt deleted file mode 100755 index 6cfd5da273..0000000000 --- a/basis/ui/gadgets/lib/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Eduardo Cavazos diff --git a/basis/ui/gadgets/lib/lib.factor b/basis/ui/gadgets/lib/lib.factor deleted file mode 100644 index 866369b0af..0000000000 --- a/basis/ui/gadgets/lib/lib.factor +++ /dev/null @@ -1,8 +0,0 @@ - -USING: accessors kernel ui.backend ui.gadgets.worlds ; - -IN: ui.gadgets.lib - -ERROR: no-world-found ; -: find-gl-context ( gadget -- ) - find-world dup [ handle>> select-gl-context ] [ no-world-found ] if ; diff --git a/basis/ui/gadgets/plot/plot.factor b/basis/ui/gadgets/plot/plot.factor deleted file mode 100644 index 52cd2faed7..0000000000 --- a/basis/ui/gadgets/plot/plot.factor +++ /dev/null @@ -1,137 +0,0 @@ - -USING: kernel quotations arrays sequences math math.ranges fry - opengl opengl.gl ui.render ui.gadgets.cartesian processing.shapes - accessors ; - -IN: ui.gadgets.plot - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -TUPLE: plot < cartesian functions points ; - -: init-plot ( plot -- plot ) - init-cartesian - { } >>functions - 100 >>points ; - -: ( -- plot ) plot new init-plot ; - -: step-size ( plot -- step-size ) - [ [ x-max>> ] [ x-min>> ] bi - ] [ points>> ] bi / ; - -: plot-range ( plot -- range ) - [ x-min>> ] [ x-max>> ] [ step-size ] tri ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -TUPLE: function function color ; - -GENERIC: plot-function ( plot object -- plot ) - -M: callable plot-function ( plot quotation -- plot ) - >r dup plot-range r> '[ dup @ 2array ] map line-strip ; - -M: function plot-function ( plot function -- plot ) - dup color>> dup [ >stroke-color ] [ drop ] if - >r dup plot-range r> function>> '[ dup @ 2array ] map line-strip ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: plot-functions ( plot -- plot ) dup functions>> [ plot-function ] each ; - -: draw-axis ( plot -- plot ) - dup - [ [ x-min>> ] [ drop 0 ] bi 2array ] - [ [ x-max>> ] [ drop 0 ] bi 2array ] bi line* - dup - [ [ drop 0 ] [ y-min>> ] bi 2array ] - [ [ drop 0 ] [ y-max>> ] bi 2array ] bi line* ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -USING: ui.gadgets.slate ; - -M: plot draw-slate ( plot -- plot ) - 2 glLineWidth - draw-axis - plot-functions - fill-mode - 1 glLineWidth ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: add-function ( plot function -- plot ) - over functions>> swap suffix >>functions ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: x-span ( plot -- span ) [ x-max>> ] [ x-min>> ] bi - ; -: y-span ( plot -- span ) [ y-max>> ] [ y-min>> ] bi - ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -USING: ui.gestures ui.gadgets ; - -: left ( plot -- plot ) - dup [ x-min>> ] [ x-span 1/10 * ] bi - >>x-min - dup [ x-max>> ] [ x-span 1/10 * ] bi - >>x-max - dup relayout-1 ; - -: right ( plot -- plot ) - dup [ x-min>> ] [ x-span 1/10 * ] bi + >>x-min - dup [ x-max>> ] [ x-span 1/10 * ] bi + >>x-max - dup relayout-1 ; - -: down ( plot -- plot ) - dup [ y-min>> ] [ y-span 1/10 * ] bi - >>y-min - dup [ y-max>> ] [ y-span 1/10 * ] bi - >>y-max - dup relayout-1 ; - -: up ( plot -- plot ) - dup [ y-min>> ] [ y-span 1/10 * ] bi + >>y-min - dup [ y-max>> ] [ y-span 1/10 * ] bi + >>y-max - dup relayout-1 ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: zoom-in-horizontal ( plot -- plot ) - dup [ x-min>> ] [ x-span 1/10 * ] bi + >>x-min - dup [ x-max>> ] [ x-span 1/10 * ] bi - >>x-max ; - -: zoom-in-vertical ( plot -- plot ) - dup [ y-min>> ] [ y-span 1/10 * ] bi + >>y-min - dup [ y-max>> ] [ y-span 1/10 * ] bi - >>y-max ; - -: zoom-in ( plot -- plot ) - zoom-in-horizontal - zoom-in-vertical - dup relayout-1 ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: zoom-out-horizontal ( plot -- plot ) - dup [ x-min>> ] [ x-span 1/10 * ] bi - >>x-min - dup [ x-max>> ] [ x-span 1/10 * ] bi + >>x-max ; - -: zoom-out-vertical ( plot -- plot ) - dup [ y-min>> ] [ y-span 1/10 * ] bi - >>y-min - dup [ y-max>> ] [ y-span 1/10 * ] bi + >>y-max ; - -: zoom-out ( plot -- plot ) - zoom-out-horizontal - zoom-out-vertical - dup relayout-1 ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -plot - H{ - { T{ mouse-enter } [ request-focus ] } - { T{ key-down f f "LEFT" } [ left drop ] } - { T{ key-down f f "RIGHT" } [ right drop ] } - { T{ key-down f f "DOWN" } [ down drop ] } - { T{ key-down f f "UP" } [ up drop ] } - { T{ key-down f f "a" } [ zoom-in drop ] } - { T{ key-down f f "z" } [ zoom-out drop ] } - } -set-gestures \ No newline at end of file diff --git a/basis/ui/gadgets/slate/authors.txt b/basis/ui/gadgets/slate/authors.txt deleted file mode 100755 index 6cfd5da273..0000000000 --- a/basis/ui/gadgets/slate/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Eduardo Cavazos diff --git a/basis/ui/gadgets/slate/slate.factor b/basis/ui/gadgets/slate/slate.factor deleted file mode 100644 index 0505586b53..0000000000 --- a/basis/ui/gadgets/slate/slate.factor +++ /dev/null @@ -1,116 +0,0 @@ - -USING: kernel namespaces opengl ui.render ui.gadgets accessors ; - -IN: ui.gadgets.slate - -TUPLE: slate < gadget action pdim graft ungraft ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: init-slate ( slate -- slate ) - init-gadget - [ ] >>action - { 200 200 } >>pdim - [ ] >>graft - [ ] >>ungraft ; - -: ( action -- slate ) - slate new - init-slate - swap >>action ; - -M: slate pref-dim* ( slate -- dim ) pdim>> ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -USING: combinators arrays sequences math math.geometry - opengl.gl ui.gadgets.worlds ; - -: screen-y* ( gadget -- loc ) - { - [ find-world height ] - [ screen-loc second ] - [ height ] - } - cleave - + - ; - -: screen-loc* ( gadget -- loc ) - { - [ screen-loc first ] - [ screen-y* ] - } - cleave - 2array ; - -: setup-viewport ( gadget -- gadget ) - dup - { - [ screen-loc* ] - [ dim>> ] - } - cleave - gl-viewport ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: default-coordinate-system ( gadget -- gadget ) - dup - { - [ drop 0 ] - [ width 1 - ] - [ height 1 - ] - [ drop 0 ] - } - cleave - -1 1 - glOrtho ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -M: slate graft* ( slate -- ) graft>> call ; -M: slate ungraft* ( slate -- ) ungraft>> call ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -GENERIC: establish-coordinate-system ( gadget -- gadget ) - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -M: slate establish-coordinate-system ( slate -- slate ) - default-coordinate-system ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -GENERIC: draw-slate ( slate -- slate ) - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -M: slate draw-slate ( slate -- slate ) dup action>> call ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -M: slate draw-gadget* ( slate -- ) - - GL_PROJECTION glMatrixMode glPushMatrix glLoadIdentity - - establish-coordinate-system - - GL_MODELVIEW glMatrixMode glPushMatrix glLoadIdentity - - setup-viewport - - draw-slate - - GL_PROJECTION glMatrixMode glPopMatrix glLoadIdentity - GL_MODELVIEW glMatrixMode glPopMatrix glLoadIdentity - - dup - find-world - ! The world coordinate system is a little wacky: - dup { [ drop 0 ] [ width ] [ height ] [ drop 0 ] } cleave -1 1 glOrtho - setup-viewport - drop - drop ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/basis/ui/gadgets/tabs/authors.txt b/basis/ui/gadgets/tabs/authors.txt deleted file mode 100755 index 50c9c38812..0000000000 --- a/basis/ui/gadgets/tabs/authors.txt +++ /dev/null @@ -1 +0,0 @@ -William Schlieper \ No newline at end of file diff --git a/basis/ui/gadgets/tabs/summary.txt b/basis/ui/gadgets/tabs/summary.txt deleted file mode 100755 index a55610bcc0..0000000000 --- a/basis/ui/gadgets/tabs/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Tabbed windows \ No newline at end of file diff --git a/basis/ui/gadgets/tabs/tabs.factor b/basis/ui/gadgets/tabs/tabs.factor deleted file mode 100755 index 50e2df2e9e..0000000000 --- a/basis/ui/gadgets/tabs/tabs.factor +++ /dev/null @@ -1,62 +0,0 @@ -! Copyright (C) 2008 William Schlieper -! See http://factorcode.org/license.txt for BSD license. - -USING: accessors kernel fry math math.vectors sequences arrays vectors assocs - hashtables models models.range models.compose combinators - ui ui.gadgets ui.gadgets.buttons ui.gadgets.frames ui.gadgets.packs - ui.gadgets.grids ui.gadgets.viewports ui.gadgets.books locals ; - -IN: ui.gadgets.tabs - -TUPLE: tabbed < frame names toggler content ; - -DEFER: (del-page) - -:: add-toggle ( model n name toggler -- ) - - n name toggler parent>> '[ , , , (del-page) ] "X" swap - @right grid-add - n model name @center grid-add - toggler swap add-gadget drop ; - -: redo-toggler ( tabbed -- ) - [ names>> ] [ model>> ] [ toggler>> ] tri - [ clear-gadget ] keep - [ [ length ] keep ] 2dip - '[ , _ _ , add-toggle ] 2each ; - -: refresh-book ( tabbed -- ) - model>> [ ] change-model ; - -: (del-page) ( n name tabbed -- ) - { [ [ remove ] change-names redo-toggler ] - [ dupd [ names>> length ] [ model>> ] bi - [ [ = ] keep swap [ 1- ] when - [ < ] keep swap [ 1- ] when ] change-model ] - [ content>> nth-gadget unparent ] - [ refresh-book ] - } cleave ; - -: add-page ( page name tabbed -- ) - [ names>> push ] 2keep - [ [ model>> swap ] - [ names>> length 1 - swap ] - [ toggler>> ] tri add-toggle ] - [ content>> swap add-gadget drop ] - [ refresh-book ] tri ; - -: del-page ( name tabbed -- ) - [ names>> index ] 2keep (del-page) ; - -: new-tabbed ( assoc class -- tabbed ) - new-frame - 0 >>model - 1 >>fill >>toggler - dup toggler>> @left grid-add - swap - [ keys >vector >>names ] - [ values over model>> >>content dup content>> @center grid-add ] - bi - dup redo-toggler ; - -: ( assoc -- tabbed ) tabbed new-tabbed ; diff --git a/basis/ui/gadgets/tiling/tiling.factor b/basis/ui/gadgets/tiling/tiling.factor deleted file mode 100644 index 2d096966af..0000000000 --- a/basis/ui/gadgets/tiling/tiling.factor +++ /dev/null @@ -1,153 +0,0 @@ - -USING: kernel sequences math math.order - ui.gadgets ui.gadgets.tracks ui.gestures - fry accessors ; - -IN: ui.gadgets.tiling - -TUPLE: tiling < track gadgets tiles first focused ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: init-tiling ( tiling -- tiling ) - init-track - { 1 0 } >>orientation - V{ } clone >>gadgets - 2 >>tiles - 0 >>first - 0 >>focused ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: ( -- gadget ) tiling new init-tiling ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: bounded-subseq ( seq a b -- seq ) - [ 0 max ] dip - pick length [ min ] curry bi@ - rot - subseq ; - -: tiling-gadgets-to-map ( tiling -- gadgets ) - [ gadgets>> ] - [ first>> ] - [ [ first>> ] [ tiles>> ] bi + ] - tri - bounded-subseq ; - -: tiling-map-gadgets ( tiling -- tiling ) - dup clear-track - dup tiling-gadgets-to-map [ 1 track-add ] each ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: tiling-add ( tiling gadget -- tiling ) - over gadgets>> push - tiling-map-gadgets ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: first-gadget ( tiling -- index ) drop 0 ; - -: last-gadget ( tiling -- index ) gadgets>> length 1 - ; - -: first-viewable ( tiling -- index ) first>> ; - -: last-viewable ( tiling -- index ) [ first>> ] [ tiles>> ] bi + 1 - ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: make-focused-mapped ( tiling -- tiling ) - - dup [ focused>> ] [ first>> ] bi < - [ dup first>> 1 - >>first ] - [ ] - if - - dup [ last-viewable ] [ focused>> ] bi < - [ dup first>> 1 + >>first ] - [ ] - if ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: check-focused-bounds ( tiling -- tiling ) - dup focused>> 0 max over gadgets>> length 1 - min >>focused ; - -: focus-prev ( tiling -- tiling ) - dup focused>> 1 - >>focused - check-focused-bounds - make-focused-mapped - tiling-map-gadgets - dup request-focus ; - -: focus-next ( tiling -- tiling ) - dup focused>> 1 + >>focused - check-focused-bounds - make-focused-mapped - tiling-map-gadgets - dup request-focus ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: exchanged! ( seq a b -- ) - [ 0 max ] bi@ - pick length 1 - '[ , min ] bi@ - rot exchange ; - -: move-prev ( tiling -- tiling ) - dup [ gadgets>> ] [ focused>> 1 - ] [ focused>> ] tri exchanged! - focus-prev ; - -: move-next ( tiling -- tiling ) - dup [ gadgets>> ] [ focused>> ] [ focused>> 1 + ] tri exchanged! - focus-next ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: add-tile ( tiling -- tiling ) - dup tiles>> 1 + >>tiles - tiling-map-gadgets ; - -: del-tile ( tiling -- tiling ) - dup tiles>> 1 - 1 max >>tiles - tiling-map-gadgets ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -M: tiling focusable-child* ( tiling -- child/t ) - [ focused>> ] [ gadgets>> ] bi nth ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -TUPLE: tiling-shelf < tiling ; -TUPLE: tiling-pile < tiling ; - -: ( -- gadget ) - tiling-shelf new init-tiling { 1 0 } >>orientation ; - -: ( -- gadget ) - tiling-pile new init-tiling { 0 1 } >>orientation ; - -tiling-shelf - H{ - { T{ key-down f { A+ } "LEFT" } [ focus-prev drop ] } - { T{ key-down f { A+ } "RIGHT" } [ focus-next drop ] } - { T{ key-down f { S+ A+ } "LEFT" } [ move-prev drop ] } - { T{ key-down f { S+ A+ } "RIGHT" } [ move-next drop ] } - { T{ key-down f { C+ } "[" } [ del-tile drop ] } - { T{ key-down f { C+ } "]" } [ add-tile drop ] } - } -set-gestures - -tiling-pile - H{ - { T{ key-down f { A+ } "UP" } [ focus-prev drop ] } - { T{ key-down f { A+ } "DOWN" } [ focus-next drop ] } - { T{ key-down f { S+ A+ } "UP" } [ move-prev drop ] } - { T{ key-down f { S+ A+ } "DOWN" } [ move-next drop ] } - { T{ key-down f { C+ } "[" } [ del-tile drop ] } - { T{ key-down f { C+ } "]" } [ add-tile drop ] } - } -set-gestures diff --git a/basis/ui/gadgets/worlds/worlds.factor b/basis/ui/gadgets/worlds/worlds.factor index bf4c275dc2..cedd03e39e 100755 --- a/basis/ui/gadgets/worlds/worlds.factor +++ b/basis/ui/gadgets/worlds/worlds.factor @@ -22,6 +22,12 @@ window-loc ; : hide-status ( gadget -- ) f swap show-status ; +ERROR: no-world-found ; + +: find-gl-context ( gadget -- ) + find-world dup + [ handle>> select-gl-context ] [ no-world-found ] if ; + : (request-focus) ( child world ? -- ) pick parent>> pick eq? [ >r >r dup parent>> dup r> r> diff --git a/basis/ui/windows/windows.factor b/basis/ui/windows/windows.factor index 5f67ed4a4b..f6481225ae 100755 --- a/basis/ui/windows/windows.factor +++ b/basis/ui/windows/windows.factor @@ -8,7 +8,7 @@ sequences strings vectors words windows.kernel32 windows.gdi32 windows.user32 windows.opengl32 windows.messages windows.types windows.nt windows threads libc combinators continuations command-line shuffle opengl ui.render unicode.case ascii -math.bitfields locals symbols accessors math.geometry.rect ; +math.bitwise locals symbols accessors math.geometry.rect ; IN: ui.windows SINGLETON: windows-ui-backend diff --git a/basis/units/authors.txt b/basis/units/authors.txt deleted file mode 100755 index 7c1b2f2279..0000000000 --- a/basis/units/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Doug Coleman diff --git a/basis/units/constants/authors.txt b/basis/units/constants/authors.txt deleted file mode 100755 index 7c1b2f2279..0000000000 --- a/basis/units/constants/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Doug Coleman diff --git a/basis/units/constants/constants.factor b/basis/units/constants/constants.factor deleted file mode 100644 index 7350cbf03d..0000000000 --- a/basis/units/constants/constants.factor +++ /dev/null @@ -1,15 +0,0 @@ -! USING: kernel math si-units ; -IN: units.constants - -! From: http://physics.nist.gov/constants - -! speed of light in vacuum -! : c 299792458 m/s ; -! : c0 299792458 m/s ; ! same as c -! : c-vacuum 299792458 m/s ; ! same as c -! -! ! more to come -! -! : avogadro -! 6.02214179e23 { } { mol } ; - diff --git a/basis/units/constants/constants.txt b/basis/units/constants/constants.txt deleted file mode 100644 index 8adc40301d..0000000000 --- a/basis/units/constants/constants.txt +++ /dev/null @@ -1,336 +0,0 @@ - - Fundamental Physical Constants --- Complete Listing - - - From: http://physics.nist.gov/constants - - - - Quantity Value Uncertainty Unit ------------------------------------------------------------------------------------------------------------------------- -{220} lattice spacing of silicon 192.015 5762 e-12 0.000 0050 e-12 m -alpha particle-electron mass ratio 7294.299 5365 0.000 0031 -alpha particle mass 6.644 656 20 e-27 0.000 000 33 e-27 kg -alpha particle mass energy equivalent 5.971 919 17 e-10 0.000 000 30 e-10 J -alpha particle mass energy equivalent in MeV 3727.379 109 0.000 093 MeV -alpha particle mass in u 4.001 506 179 127 0.000 000 000 062 u -alpha particle molar mass 4.001 506 179 127 e-3 0.000 000 000 062 e-3 kg mol^-1 -alpha particle-proton mass ratio 3.972 599 689 51 0.000 000 000 41 -Angstrom star 1.000 014 98 e-10 0.000 000 90 e-10 m -atomic mass constant 1.660 538 782 e-27 0.000 000 083 e-27 kg -atomic mass constant energy equivalent 1.492 417 830 e-10 0.000 000 074 e-10 J -atomic mass constant energy equivalent in MeV 931.494 028 0.000 023 MeV -atomic mass unit-electron volt relationship 931.494 028 e6 0.000 023 e6 eV -atomic mass unit-hartree relationship 3.423 177 7149 e7 0.000 000 0049 e7 E_h -atomic mass unit-hertz relationship 2.252 342 7369 e23 0.000 000 0032 e23 Hz -atomic mass unit-inverse meter relationship 7.513 006 671 e14 0.000 000 011 e14 m^-1 -atomic mass unit-joule relationship 1.492 417 830 e-10 0.000 000 074 e-10 J -atomic mass unit-kelvin relationship 1.080 9527 e13 0.000 0019 e13 K -atomic mass unit-kilogram relationship 1.660 538 782 e-27 0.000 000 083 e-27 kg -atomic unit of 1st hyperpolarizablity 3.206 361 533 e-53 0.000 000 081 e-53 C^3 m^3 J^-2 -atomic unit of 2nd hyperpolarizablity 6.235 380 95 e-65 0.000 000 31 e-65 C^4 m^4 J^-3 -atomic unit of action 1.054 571 628 e-34 0.000 000 053 e-34 J s -atomic unit of charge 1.602 176 487 e-19 0.000 000 040 e-19 C -atomic unit of charge density 1.081 202 300 e12 0.000 000 027 e12 C m^-3 -atomic unit of current 6.623 617 63 e-3 0.000 000 17 e-3 A -atomic unit of electric dipole mom. 8.478 352 81 e-30 0.000 000 21 e-30 C m -atomic unit of electric field 5.142 206 32 e11 0.000 000 13 e11 V m^-1 -atomic unit of electric field gradient 9.717 361 66 e21 0.000 000 24 e21 V m^-2 -atomic unit of electric polarizablity 1.648 777 2536 e-41 0.000 000 0034 e-41 C^2 m^2 J^-1 -atomic unit of electric potential 27.211 383 86 0.000 000 68 V -atomic unit of electric quadrupole mom. 4.486 551 07 e-40 0.000 000 11 e-40 C m^2 -atomic unit of energy 4.359 743 94 e-18 0.000 000 22 e-18 J -atomic unit of force 8.238 722 06 e-8 0.000 000 41 e-8 N -atomic unit of length 0.529 177 208 59 e-10 0.000 000 000 36 e-10 m -atomic unit of mag. dipole mom. 1.854 801 830 e-23 0.000 000 046 e-23 J T^-1 -atomic unit of mag. flux density 2.350 517 382 e5 0.000 000 059 e5 T -atomic unit of magnetizability 7.891 036 433 e-29 0.000 000 027 e-29 J T^-2 -atomic unit of mass 9.109 382 15 e-31 0.000 000 45 e-31 kg -atomic unit of momentum 1.992 851 565 e-24 0.000 000 099 e-24 kg m s^-1 -atomic unit of permittivity 1.112 650 056... e-10 (exact) F m^-1 -atomic unit of time 2.418 884 326 505 e-17 0.000 000 000 016 e-17 s -atomic unit of velocity 2.187 691 2541 e6 0.000 000 0015 e6 m s^-1 -Avogadro constant 6.022 141 79 e23 0.000 000 30 e23 mol^-1 -Bohr magneton 927.400 915 e-26 0.000 023 e-26 J T^-1 -Bohr magneton in eV/T 5.788 381 7555 e-5 0.000 000 0079 e-5 eV T^-1 -Bohr magneton in Hz/T 13.996 246 04 e9 0.000 000 35 e9 Hz T^-1 -Bohr magneton in inverse meters per tesla 46.686 4515 0.000 0012 m^-1 T^-1 -Bohr magneton in K/T 0.671 7131 0.000 0012 K T^-1 -Bohr radius 0.529 177 208 59 e-10 0.000 000 000 36 e-10 m -Boltzmann constant 1.380 6504 e-23 0.000 0024 e-23 J K^-1 -Boltzmann constant in eV/K 8.617 343 e-5 0.000 015 e-5 eV K^-1 -Boltzmann constant in Hz/K 2.083 6644 e10 0.000 0036 e10 Hz K^-1 -Boltzmann constant in inverse meters per kelvin 69.503 56 0.000 12 m^-1 K^-1 -characteristic impedance of vacuum 376.730 313 461... (exact) ohm -classical electron radius 2.817 940 2894 e-15 0.000 000 0058 e-15 m -Compton wavelength 2.426 310 2175 e-12 0.000 000 0033 e-12 m -Compton wavelength over 2 pi 386.159 264 59 e-15 0.000 000 53 e-15 m -conductance quantum 7.748 091 7004 e-5 0.000 000 0053 e-5 S -conventional value of Josephson constant 483 597.9 e9 (exact) Hz V^-1 -conventional value of von Klitzing constant 25 812.807 (exact) ohm -Cu x unit 1.002 076 99 e-13 0.000 000 28 e-13 m -deuteron-electron mag. mom. ratio -4.664 345 537 e-4 0.000 000 039 e-4 -deuteron-electron mass ratio 3670.482 9654 0.000 0016 -deuteron g factor 0.857 438 2308 0.000 000 0072 -deuteron mag. mom. 0.433 073 465 e-26 0.000 000 011 e-26 J T^-1 -deuteron mag. mom. to Bohr magneton ratio 0.466 975 4556 e-3 0.000 000 0039 e-3 -deuteron mag. mom. to nuclear magneton ratio 0.857 438 2308 0.000 000 0072 -deuteron mass 3.343 583 20 e-27 0.000 000 17 e-27 kg -deuteron mass energy equivalent 3.005 062 72 e-10 0.000 000 15 e-10 J -deuteron mass energy equivalent in MeV 1875.612 793 0.000 047 MeV -deuteron mass in u 2.013 553 212 724 0.000 000 000 078 u -deuteron molar mass 2.013 553 212 724 e-3 0.000 000 000 078 e-3 kg mol^-1 -deuteron-neutron mag. mom. ratio -0.448 206 52 0.000 000 11 -deuteron-proton mag. mom. ratio 0.307 012 2070 0.000 000 0024 -deuteron-proton mass ratio 1.999 007 501 08 0.000 000 000 22 -deuteron rms charge radius 2.1402 e-15 0.0028 e-15 m -electric constant 8.854 187 817... e-12 (exact) F m^-1 -electron charge to mass quotient -1.758 820 150 e11 0.000 000 044 e11 C kg^-1 -electron-deuteron mag. mom. ratio -2143.923 498 0.000 018 -electron-deuteron mass ratio 2.724 437 1093 e-4 0.000 000 0012 e-4 -electron g factor -2.002 319 304 3622 0.000 000 000 0015 -electron gyromag. ratio 1.760 859 770 e11 0.000 000 044 e11 s^-1 T^-1 -electron gyromag. ratio over 2 pi 28 024.953 64 0.000 70 MHz T^-1 -electron mag. mom. -928.476 377 e-26 0.000 023 e-26 J T^-1 -electron mag. mom. anomaly 1.159 652 181 11 e-3 0.000 000 000 74 e-3 -electron mag. mom. to Bohr magneton ratio -1.001 159 652 181 11 0.000 000 000 000 74 -electron mag. mom. to nuclear magneton ratio -1838.281 970 92 0.000 000 80 -electron mass 9.109 382 15 e-31 0.000 000 45 e-31 kg -electron mass energy equivalent 8.187 104 38 e-14 0.000 000 41 e-14 J -electron mass energy equivalent in MeV 0.510 998 910 0.000 000 013 MeV -electron mass in u 5.485 799 0943 e-4 0.000 000 0023 e-4 u -electron molar mass 5.485 799 0943 e-7 0.000 000 0023 e-7 kg mol^-1 -electron-muon mag. mom. ratio 206.766 9877 0.000 0052 -electron-muon mass ratio 4.836 331 71 e-3 0.000 000 12 e-3 -electron-neutron mag. mom. ratio 960.920 50 0.000 23 -electron-neutron mass ratio 5.438 673 4459 e-4 0.000 000 0033 e-4 -electron-proton mag. mom. ratio -658.210 6848 0.000 0054 -electron-proton mass ratio 5.446 170 2177 e-4 0.000 000 0024 e-4 -electron-tau mass ratio 2.875 64 e-4 0.000 47 e-4 -electron to alpha particle mass ratio 1.370 933 555 70 e-4 0.000 000 000 58 e-4 -electron to shielded helion mag. mom. ratio 864.058 257 0.000 010 -electron to shielded proton mag. mom. ratio -658.227 5971 0.000 0072 -electron volt 1.602 176 487 e-19 0.000 000 040 e-19 J -electron volt-atomic mass unit relationship 1.073 544 188 e-9 0.000 000 027 e-9 u -electron volt-hartree relationship 3.674 932 540 e-2 0.000 000 092 e-2 E_h -electron volt-hertz relationship 2.417 989 454 e14 0.000 000 060 e14 Hz -electron volt-inverse meter relationship 8.065 544 65 e5 0.000 000 20 e5 m^-1 -electron volt-joule relationship 1.602 176 487 e-19 0.000 000 040 e-19 J -electron volt-kelvin relationship 1.160 4505 e4 0.000 0020 e4 K -electron volt-kilogram relationship 1.782 661 758 e-36 0.000 000 044 e-36 kg -elementary charge 1.602 176 487 e-19 0.000 000 040 e-19 C -elementary charge over h 2.417 989 454 e14 0.000 000 060 e14 A J^-1 -Faraday constant 96 485.3399 0.0024 C mol^-1 -Faraday constant for conventional electric current 96 485.3401 0.0048 C_90 mol^-1 -Fermi coupling constant 1.166 37 e-5 0.000 01 e-5 GeV^-2 -fine-structure constant 7.297 352 5376 e-3 0.000 000 0050 e-3 -first radiation constant 3.741 771 18 e-16 0.000 000 19 e-16 W m^2 -first radiation constant for spectral radiance 1.191 042 759 e-16 0.000 000 059 e-16 W m^2 sr^-1 -hartree-atomic mass unit relationship 2.921 262 2986 e-8 0.000 000 0042 e-8 u -hartree-electron volt relationship 27.211 383 86 0.000 000 68 eV -Hartree energy 4.359 743 94 e-18 0.000 000 22 e-18 J -Hartree energy in eV 27.211 383 86 0.000 000 68 eV -hartree-hertz relationship 6.579 683 920 722 e15 0.000 000 000 044 e15 Hz -hartree-inverse meter relationship 2.194 746 313 705 e7 0.000 000 000 015 e7 m^-1 -hartree-joule relationship 4.359 743 94 e-18 0.000 000 22 e-18 J -hartree-kelvin relationship 3.157 7465 e5 0.000 0055 e5 K -hartree-kilogram relationship 4.850 869 34 e-35 0.000 000 24 e-35 kg -helion-electron mass ratio 5495.885 2765 0.000 0052 -helion mass 5.006 411 92 e-27 0.000 000 25 e-27 kg -helion mass energy equivalent 4.499 538 64 e-10 0.000 000 22 e-10 J -helion mass energy equivalent in MeV 2808.391 383 0.000 070 MeV -helion mass in u 3.014 932 2473 0.000 000 0026 u -helion molar mass 3.014 932 2473 e-3 0.000 000 0026 e-3 kg mol^-1 -helion-proton mass ratio 2.993 152 6713 0.000 000 0026 -hertz-atomic mass unit relationship 4.439 821 6294 e-24 0.000 000 0064 e-24 u -hertz-electron volt relationship 4.135 667 33 e-15 0.000 000 10 e-15 eV -hertz-hartree relationship 1.519 829 846 006 e-16 0.000 000 000 010 e-16 E_h -hertz-inverse meter relationship 3.335 640 951... e-9 (exact) m^-1 -hertz-joule relationship 6.626 068 96 e-34 0.000 000 33 e-34 J -hertz-kelvin relationship 4.799 2374 e-11 0.000 0084 e-11 K -hertz-kilogram relationship 7.372 496 00 e-51 0.000 000 37 e-51 kg -inverse fine-structure constant 137.035 999 679 0.000 000 094 -inverse meter-atomic mass unit relationship 1.331 025 0394 e-15 0.000 000 0019 e-15 u -inverse meter-electron volt relationship 1.239 841 875 e-6 0.000 000 031 e-6 eV -inverse meter-hartree relationship 4.556 335 252 760 e-8 0.000 000 000 030 e-8 E_h -inverse meter-hertz relationship 299 792 458 (exact) Hz -inverse meter-joule relationship 1.986 445 501 e-25 0.000 000 099 e-25 J -inverse meter-kelvin relationship 1.438 7752 e-2 0.000 0025 e-2 K -inverse meter-kilogram relationship 2.210 218 70 e-42 0.000 000 11 e-42 kg -inverse of conductance quantum 12 906.403 7787 0.000 0088 ohm -Josephson constant 483 597.891 e9 0.012 e9 Hz V^-1 -joule-atomic mass unit relationship 6.700 536 41 e9 0.000 000 33 e9 u -joule-electron volt relationship 6.241 509 65 e18 0.000 000 16 e18 eV -joule-hartree relationship 2.293 712 69 e17 0.000 000 11 e17 E_h -joule-hertz relationship 1.509 190 450 e33 0.000 000 075 e33 Hz -joule-inverse meter relationship 5.034 117 47 e24 0.000 000 25 e24 m^-1 -joule-kelvin relationship 7.242 963 e22 0.000 013 e22 K -joule-kilogram relationship 1.112 650 056... e-17 (exact) kg -kelvin-atomic mass unit relationship 9.251 098 e-14 0.000 016 e-14 u -kelvin-electron volt relationship 8.617 343 e-5 0.000 015 e-5 eV -kelvin-hartree relationship 3.166 8153 e-6 0.000 0055 e-6 E_h -kelvin-hertz relationship 2.083 6644 e10 0.000 0036 e10 Hz -kelvin-inverse meter relationship 69.503 56 0.000 12 m^-1 -kelvin-joule relationship 1.380 6504 e-23 0.000 0024 e-23 J -kelvin-kilogram relationship 1.536 1807 e-40 0.000 0027 e-40 kg -kilogram-atomic mass unit relationship 6.022 141 79 e26 0.000 000 30 e26 u -kilogram-electron volt relationship 5.609 589 12 e35 0.000 000 14 e35 eV -kilogram-hartree relationship 2.061 486 16 e34 0.000 000 10 e34 E_h -kilogram-hertz relationship 1.356 392 733 e50 0.000 000 068 e50 Hz -kilogram-inverse meter relationship 4.524 439 15 e41 0.000 000 23 e41 m^-1 -kilogram-joule relationship 8.987 551 787... e16 (exact) J -kilogram-kelvin relationship 6.509 651 e39 0.000 011 e39 K -lattice parameter of silicon 543.102 064 e-12 0.000 014 e-12 m -Loschmidt constant (273.15 K, 101.325 kPa) 2.686 7774 e25 0.000 0047 e25 m^-3 -mag. constant 12.566 370 614... e-7 (exact) N A^-2 -mag. flux quantum 2.067 833 667 e-15 0.000 000 052 e-15 Wb -molar gas constant 8.314 472 0.000 015 J mol^-1 K^-1 -molar mass constant 1 e-3 (exact) kg mol^-1 -molar mass of carbon-12 12 e-3 (exact) kg mol^-1 -molar Planck constant 3.990 312 6821 e-10 0.000 000 0057 e-10 J s mol^-1 -molar Planck constant times c 0.119 626 564 72 0.000 000 000 17 J m mol^-1 -molar volume of ideal gas (273.15 K, 100 kPa) 22.710 981 e-3 0.000 040 e-3 m^3 mol^-1 -molar volume of ideal gas (273.15 K, 101.325 kPa) 22.413 996 e-3 0.000 039 e-3 m^3 mol^-1 -molar volume of silicon 12.058 8349 e-6 0.000 0011 e-6 m^3 mol^-1 -Mo x unit 1.002 099 55 e-13 0.000 000 53 e-13 m -muon Compton wavelength 11.734 441 04 e-15 0.000 000 30 e-15 m -muon Compton wavelength over 2 pi 1.867 594 295 e-15 0.000 000 047 e-15 m -muon-electron mass ratio 206.768 2823 0.000 0052 -muon g factor -2.002 331 8414 0.000 000 0012 -muon mag. mom. -4.490 447 86 e-26 0.000 000 16 e-26 J T^-1 -muon mag. mom. anomaly 1.165 920 69 e-3 0.000 000 60 e-3 -muon mag. mom. to Bohr magneton ratio -4.841 970 49 e-3 0.000 000 12 e-3 -muon mag. mom. to nuclear magneton ratio -8.890 597 05 0.000 000 23 -muon mass 1.883 531 30 e-28 0.000 000 11 e-28 kg -muon mass energy equivalent 1.692 833 510 e-11 0.000 000 095 e-11 J -muon mass energy equivalent in MeV 105.658 3668 0.000 0038 MeV -muon mass in u 0.113 428 9256 0.000 000 0029 u -muon molar mass 0.113 428 9256 e-3 0.000 000 0029 e-3 kg mol^-1 -muon-neutron mass ratio 0.112 454 5167 0.000 000 0029 -muon-proton mag. mom. ratio -3.183 345 137 0.000 000 085 -muon-proton mass ratio 0.112 609 5261 0.000 000 0029 -muon-tau mass ratio 5.945 92 e-2 0.000 97 e-2 -natural unit of action 1.054 571 628 e-34 0.000 000 053 e-34 J s -natural unit of action in eV s 6.582 118 99 e-16 0.000 000 16 e-16 eV s -natural unit of energy 8.187 104 38 e-14 0.000 000 41 e-14 J -natural unit of energy in MeV 0.510 998 910 0.000 000 013 MeV -natural unit of length 386.159 264 59 e-15 0.000 000 53 e-15 m -natural unit of mass 9.109 382 15 e-31 0.000 000 45 e-31 kg -natural unit of momentum 2.730 924 06 e-22 0.000 000 14 e-22 kg m s^-1 -natural unit of momentum in MeV/c 0.510 998 910 0.000 000 013 MeV/c -natural unit of time 1.288 088 6570 e-21 0.000 000 0018 e-21 s -natural unit of velocity 299 792 458 (exact) m s^-1 -neutron Compton wavelength 1.319 590 8951 e-15 0.000 000 0020 e-15 m -neutron Compton wavelength over 2 pi 0.210 019 413 82 e-15 0.000 000 000 31 e-15 m -neutron-electron mag. mom. ratio 1.040 668 82 e-3 0.000 000 25 e-3 -neutron-electron mass ratio 1838.683 6605 0.000 0011 -neutron g factor -3.826 085 45 0.000 000 90 -neutron gyromag. ratio 1.832 471 85 e8 0.000 000 43 e8 s^-1 T^-1 -neutron gyromag. ratio over 2 pi 29.164 6954 0.000 0069 MHz T^-1 -neutron mag. mom. -0.966 236 41 e-26 0.000 000 23 e-26 J T^-1 -neutron mag. mom. to Bohr magneton ratio -1.041 875 63 e-3 0.000 000 25 e-3 -neutron mag. mom. to nuclear magneton ratio -1.913 042 73 0.000 000 45 -neutron mass 1.674 927 211 e-27 0.000 000 084 e-27 kg -neutron mass energy equivalent 1.505 349 505 e-10 0.000 000 075 e-10 J -neutron mass energy equivalent in MeV 939.565 346 0.000 023 MeV -neutron mass in u 1.008 664 915 97 0.000 000 000 43 u -neutron molar mass 1.008 664 915 97 e-3 0.000 000 000 43 e-3 kg mol^-1 -neutron-muon mass ratio 8.892 484 09 0.000 000 23 -neutron-proton mag. mom. ratio -0.684 979 34 0.000 000 16 -neutron-proton mass ratio 1.001 378 419 18 0.000 000 000 46 -neutron-tau mass ratio 0.528 740 0.000 086 -neutron to shielded proton mag. mom. ratio -0.684 996 94 0.000 000 16 -Newtonian constant of gravitation 6.674 28 e-11 0.000 67 e-11 m^3 kg^-1 s^-2 -Newtonian constant of gravitation over h-bar c 6.708 81 e-39 0.000 67 e-39 (GeV/c^2)^-2 -nuclear magneton 5.050 783 24 e-27 0.000 000 13 e-27 J T^-1 -nuclear magneton in eV/T 3.152 451 2326 e-8 0.000 000 0045 e-8 eV T^-1 -nuclear magneton in inverse meters per tesla 2.542 623 616 e-2 0.000 000 064 e-2 m^-1 T^-1 -nuclear magneton in K/T 3.658 2637 e-4 0.000 0064 e-4 K T^-1 -nuclear magneton in MHz/T 7.622 593 84 0.000 000 19 MHz T^-1 -Planck constant 6.626 068 96 e-34 0.000 000 33 e-34 J s -Planck constant in eV s 4.135 667 33 e-15 0.000 000 10 e-15 eV s -Planck constant over 2 pi 1.054 571 628 e-34 0.000 000 053 e-34 J s -Planck constant over 2 pi in eV s 6.582 118 99 e-16 0.000 000 16 e-16 eV s -Planck constant over 2 pi times c in MeV fm 197.326 9631 0.000 0049 MeV fm -Planck length 1.616 252 e-35 0.000 081 e-35 m -Planck mass 2.176 44 e-8 0.000 11 e-8 kg -Planck mass energy equivalent in GeV 1.220 892 e19 0.000 061 e19 GeV -Planck temperature 1.416 785 e32 0.000 071 e32 K -Planck time 5.391 24 e-44 0.000 27 e-44 s -proton charge to mass quotient 9.578 833 92 e7 0.000 000 24 e7 C kg^-1 -proton Compton wavelength 1.321 409 8446 e-15 0.000 000 0019 e-15 m -proton Compton wavelength over 2 pi 0.210 308 908 61 e-15 0.000 000 000 30 e-15 m -proton-electron mass ratio 1836.152 672 47 0.000 000 80 -proton g factor 5.585 694 713 0.000 000 046 -proton gyromag. ratio 2.675 222 099 e8 0.000 000 070 e8 s^-1 T^-1 -proton gyromag. ratio over 2 pi 42.577 4821 0.000 0011 MHz T^-1 -proton mag. mom. 1.410 606 662 e-26 0.000 000 037 e-26 J T^-1 -proton mag. mom. to Bohr magneton ratio 1.521 032 209 e-3 0.000 000 012 e-3 -proton mag. mom. to nuclear magneton ratio 2.792 847 356 0.000 000 023 -proton mag. shielding correction 25.694 e-6 0.014 e-6 -proton mass 1.672 621 637 e-27 0.000 000 083 e-27 kg -proton mass energy equivalent 1.503 277 359 e-10 0.000 000 075 e-10 J -proton mass energy equivalent in MeV 938.272 013 0.000 023 MeV -proton mass in u 1.007 276 466 77 0.000 000 000 10 u -proton molar mass 1.007 276 466 77 e-3 0.000 000 000 10 e-3 kg mol^-1 -proton-muon mass ratio 8.880 243 39 0.000 000 23 -proton-neutron mag. mom. ratio -1.459 898 06 0.000 000 34 -proton-neutron mass ratio 0.998 623 478 24 0.000 000 000 46 -proton rms charge radius 0.8768 e-15 0.0069 e-15 m -proton-tau mass ratio 0.528 012 0.000 086 -quantum of circulation 3.636 947 5199 e-4 0.000 000 0050 e-4 m^2 s^-1 -quantum of circulation times 2 7.273 895 040 e-4 0.000 000 010 e-4 m^2 s^-1 -Rydberg constant 10 973 731.568 527 0.000 073 m^-1 -Rydberg constant times c in Hz 3.289 841 960 361 e15 0.000 000 000 022 e15 Hz -Rydberg constant times hc in eV 13.605 691 93 0.000 000 34 eV -Rydberg constant times hc in J 2.179 871 97 e-18 0.000 000 11 e-18 J -Sackur-Tetrode constant (1 K, 100 kPa) -1.151 7047 0.000 0044 -Sackur-Tetrode constant (1 K, 101.325 kPa) -1.164 8677 0.000 0044 -second radiation constant 1.438 7752 e-2 0.000 0025 e-2 m K -shielded helion gyromag. ratio 2.037 894 730 e8 0.000 000 056 e8 s^-1 T^-1 -shielded helion gyromag. ratio over 2 pi 32.434 101 98 0.000 000 90 MHz T^-1 -shielded helion mag. mom. -1.074 552 982 e-26 0.000 000 030 e-26 J T^-1 -shielded helion mag. mom. to Bohr magneton ratio -1.158 671 471 e-3 0.000 000 014 e-3 -shielded helion mag. mom. to nuclear magneton ratio -2.127 497 718 0.000 000 025 -shielded helion to proton mag. mom. ratio -0.761 766 558 0.000 000 011 -shielded helion to shielded proton mag. mom. ratio -0.761 786 1313 0.000 000 0033 -shielded proton gyromag. ratio 2.675 153 362 e8 0.000 000 073 e8 s^-1 T^-1 -shielded proton gyromag. ratio over 2 pi 42.576 3881 0.000 0012 MHz T^-1 -shielded proton mag. mom. 1.410 570 419 e-26 0.000 000 038 e-26 J T^-1 -shielded proton mag. mom. to Bohr magneton ratio 1.520 993 128 e-3 0.000 000 017 e-3 -shielded proton mag. mom. to nuclear magneton ratio 2.792 775 598 0.000 000 030 -speed of light in vacuum 299 792 458 (exact) m s^-1 -standard acceleration of gravity 9.806 65 (exact) m s^-2 -standard atmosphere 101 325 (exact) Pa -Stefan-Boltzmann constant 5.670 400 e-8 0.000 040 e-8 W m^-2 K^-4 -tau Compton wavelength 0.697 72 e-15 0.000 11 e-15 m -tau Compton wavelength over 2 pi 0.111 046 e-15 0.000 018 e-15 m -tau-electron mass ratio 3477.48 0.57 -tau mass 3.167 77 e-27 0.000 52 e-27 kg -tau mass energy equivalent 2.847 05 e-10 0.000 46 e-10 J -tau mass energy equivalent in MeV 1776.99 0.29 MeV -tau mass in u 1.907 68 0.000 31 u -tau molar mass 1.907 68 e-3 0.000 31 e-3 kg mol^-1 -tau-muon mass ratio 16.8183 0.0027 -tau-neutron mass ratio 1.891 29 0.000 31 -tau-proton mass ratio 1.893 90 0.000 31 -Thomson cross section 0.665 245 8558 e-28 0.000 000 0027 e-28 m^2 -triton-electron mag. mom. ratio -1.620 514 423 e-3 0.000 000 021 e-3 -triton-electron mass ratio 5496.921 5269 0.000 0051 -triton g factor 5.957 924 896 0.000 000 076 -triton mag. mom. 1.504 609 361 e-26 0.000 000 042 e-26 J T^-1 -triton mag. mom. to Bohr magneton ratio 1.622 393 657 e-3 0.000 000 021 e-3 -triton mag. mom. to nuclear magneton ratio 2.978 962 448 0.000 000 038 -triton mass 5.007 355 88 e-27 0.000 000 25 e-27 kg -triton mass energy equivalent 4.500 387 03 e-10 0.000 000 22 e-10 J -triton mass energy equivalent in MeV 2808.920 906 0.000 070 MeV -triton mass in u 3.015 500 7134 0.000 000 0025 u -triton molar mass 3.015 500 7134 e-3 0.000 000 0025 e-3 kg mol^-1 -triton-neutron mag. mom. ratio -1.557 185 53 0.000 000 37 -triton-proton mag. mom. ratio 1.066 639 908 0.000 000 010 -triton-proton mass ratio 2.993 717 0309 0.000 000 0025 -unified atomic mass unit 1.660 538 782 e-27 0.000 000 083 e-27 kg -von Klitzing constant 25 812.807 557 0.000 018 ohm -weak mixing angle 0.222 55 0.000 56 -Wien frequency displacement law constant 5.878 933 e10 0.000 010 e10 Hz K^-1 -Wien wavelength displacement law constant 2.897 7685 e-3 0.000 0051 e-3 m K diff --git a/basis/units/imperial/authors.txt b/basis/units/imperial/authors.txt deleted file mode 100755 index 7c1b2f2279..0000000000 --- a/basis/units/imperial/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Doug Coleman diff --git a/basis/units/imperial/imperial-tests.factor b/basis/units/imperial/imperial-tests.factor deleted file mode 100644 index 793fe5679d..0000000000 --- a/basis/units/imperial/imperial-tests.factor +++ /dev/null @@ -1,21 +0,0 @@ -USING: kernel math tools.test units.imperial inverse ; -IN: units.imperial.tests - -[ 1 ] [ 12 inches [ feet ] undo ] unit-test -[ 12 ] [ 1 feet [ inches ] undo ] unit-test - -[ t ] [ 16 ounces 1 pounds = ] unit-test -[ t ] [ 1 pounds [ ounces ] undo 16 = ] unit-test - -[ 1 ] [ 4 quarts [ gallons ] undo ] unit-test -[ 4 ] [ 1 gallons [ quarts ] undo ] unit-test - -[ 2 ] [ 1 pints [ cups ] undo ] unit-test -[ 1 ] [ 2 cups [ pints ] undo ] unit-test - -[ 256 ] [ 1 gallons [ tablespoons ] undo ] unit-test -[ 1 ] [ 256 tablespoons [ gallons ] undo ] unit-test - -[ 768 ] [ 1 gallons [ teaspoons ] undo ] unit-test -[ 1 ] [ 768 teaspoons [ gallons ] undo ] unit-test - diff --git a/basis/units/imperial/imperial.factor b/basis/units/imperial/imperial.factor deleted file mode 100644 index a0c6350227..0000000000 --- a/basis/units/imperial/imperial.factor +++ /dev/null @@ -1,63 +0,0 @@ -USING: kernel math prettyprint units units.si inverse ; -IN: units.imperial - -: inches ( n -- dimensioned ) 254/100 * cm ; - -: feet ( n -- dimensioned ) 12 * inches ; - -: yards ( n -- dimensioned ) 3 * feet ; - -: miles ( n -- dimensioned ) 1760 * yards ; - -: nautical-miles ( n -- dimensioned ) 1852 * m ; - -: pounds ( n -- dimensioned ) 22/10 / kg ; - -: ounces ( n -- dimensioned ) 1/16 * pounds ; - -: gallons ( n -- dimensioned ) 379/100 * L ; - -: quarts ( n -- dimensioned ) 1/4 * gallons ; - -: pints ( n -- dimensioned ) 1/2 * quarts ; - -: cups ( n -- dimensioned ) 1/2 * pints ; - -: fluid-ounces ( n -- dimensioned ) 1/16 * pints ; - -: teaspoons ( n -- dimensioned ) 1/6 * fluid-ounces ; - -: tablespoons ( n -- dimensioned ) 1/2 * fluid-ounces ; - -: knots ( n -- dimensioned ) 1852/3600 * m/s ; - -: deg-F ( n -- dimensioned ) 32 - 5/9 * deg-C ; - -: imperial-gallons ( n -- dimensioned ) 454609/100000 * L ; - -: imperial-quarts ( n -- dimensioned ) 1/4 * imperial-gallons ; - -: imperial-pints ( n -- dimensioned ) 1/2 * imperial-quarts ; - -: imperial-fluid-ounces ( n -- dimensioned ) 1/160 * imperial-gallons ; - -: imperial-gill ( n -- dimensioned ) 5 * imperial-fluid-ounces ; - -: dry-gallons ( n -- dimensioned ) 440488377086/100000000000 * L ; - -: dry-quarts ( n -- dimensioned ) 1/4 * dry-gallons ; - -: dry-pints ( n -- dimensioned ) 1/2 * dry-quarts ; - -: pecks ( n -- dimensioned ) 8 * dry-quarts ; - -: bushels ( n -- dimensioned ) 4 * pecks ; - -: rods ( n -- dimensioned ) 11/2 * yards ; - - - - - - -! rod, hogshead, barrel, peck, metric ton, imperial ton.. diff --git a/basis/units/si/authors.txt b/basis/units/si/authors.txt deleted file mode 100755 index 7c1b2f2279..0000000000 --- a/basis/units/si/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Doug Coleman diff --git a/basis/units/si/si-tests.factor b/basis/units/si/si-tests.factor deleted file mode 100644 index 9fb702f050..0000000000 --- a/basis/units/si/si-tests.factor +++ /dev/null @@ -1,13 +0,0 @@ -USING: kernel tools.test units.si inverse math.constants -math.functions units.imperial ; -IN: units.si.tests - -[ t ] [ 1 m 100 cm = ] unit-test - -[ t ] [ 180 arc-deg [ radians ] undo pi 0.0001 ~ ] unit-test - -[ t ] [ 180 arc-min [ arc-deg ] undo 3 0.0001 ~ ] unit-test - -[ -40 ] [ -40 deg-F [ deg-C ] undo ] unit-test - -[ -40 ] [ -40 deg-C [ deg-F ] undo ] unit-test diff --git a/basis/units/si/si.factor b/basis/units/si/si.factor deleted file mode 100644 index 66f7c1e7a7..0000000000 --- a/basis/units/si/si.factor +++ /dev/null @@ -1,125 +0,0 @@ -USING: kernel math math.constants sequences units ; -IN: units.si - -! SI Conversions -! http://physics.nist.gov/cuu/Units/ - -! Length -: m ( n -- dimensioned ) { m } { } ; - -! Mass -: kg ( n -- dimensioned ) { kg } { } ; - -! Time -: s ( n -- dimensioned ) { s } { } ; - -! Electric current -: A ( n -- dimensioned ) { A } { } ; - -! Temperature -: K ( n -- dimensioned ) { K } { } ; - -! Amount of substance -: mol ( n -- dimensioned ) { mol } { } ; - -! Luminous intensity -: cd ( n -- dimensioned ) { cd } { } ; - -! SI derived units -: m^2 ( n -- dimensioned ) { m m } { } ; -: m^3 ( n -- dimensioned ) { m m m } { } ; -: m/s ( n -- dimensioned ) { m } { s } ; -: m/s^2 ( n -- dimensioned ) { m } { s s } ; -: 1/m ( n -- dimensioned ) { } { m } ; -: kg/m^3 ( n -- dimensioned ) { kg } { m m m } ; -: A/m^2 ( n -- dimensioned ) { A } { m m } ; -: A/m ( n -- dimensioned ) { A } { m } ; -: mol/m^3 ( n -- dimensioned ) { mol } { m m m } ; -: cd/m^2 ( n -- dimensioned ) { cd } { m m } ; -: kg/kg ( n -- dimensioned ) { kg } { kg } ; - -! Radians are really m/m, and steradians are m^2/m^2 -! but they need to be in reduced form here. -: radians ( n -- radian ) scalar ; -: sr ( n -- steradian ) scalar ; - -: Hz ( n -- hertz ) { } { s } ; -: N ( n -- newton ) { kg m } { s s } ; -: Pa ( n -- pascal ) { kg } { m s s } ; -: J ( n -- joule ) { m m kg } { s s } ; -: W ( n -- watt ) { m m kg } { s s s } ; -: C ( n -- coulomb ) { s A } { } ; -: V ( n -- volt ) { m m kg } { s s s A } ; -: F ( n -- farad ) { s s s s A A } { m m kg } ; -: ohm ( n -- ohm ) { m m kg } { s s s A A } ; -: S ( n -- siemens ) { s s s A A } { m m kg } ; -: Wb ( n -- weber ) { m m kg } { s s A } ; -: T ( n -- tesla ) { kg } { s s A } ; -: H ( n -- henry ) { m m kg } { s s A A } ; -: deg-C ( n -- Celsius ) 27315/100 + { K } { } ; -: lm ( n -- lumen ) { m m cd } { m m } ; -: lx ( n -- lux ) { m m cd } { m m m m } ; -: Bq ( n -- becquerel ) { } { s } ; -: Gy ( n -- gray ) { m m } { s s } ; -: Sv ( n -- sievert ) { m m } { s s } ; -: kat ( n -- katal ) { mol } { s } ; - -! Extensions to the SI -: arc-deg ( n -- x ) pi 180 / * radians ; -: arc-min ( n -- x ) pi 10800 / * radians ; -: arc-sec ( n -- x ) pi 648000 / * radians ; -: L ( n -- liter ) 1/1000 * m^3 ; -: tons ( n -- metric-ton ) 1000 * kg ; -: Np ( n -- neper ) { } { } ; -: B ( n -- bel ) 1.151292546497023 * Np ; -: eV ( n -- electronvolt ) 1.60218e-19 * J ; -: u ( n -- unified-atomic-mass-unit ) 1.66054e-27 * kg ; - -! au has error of 30m, according to wikipedia -: au ( n -- astronomical-unit ) 149597870691 * m ; - -: a ( n -- are ) 100 * m^2 ; -: ha ( n -- hectare ) 10000 * m^2 ; -: bar ( n -- bar ) 100000 * Pa ; -: b ( n -- barn ) 1/10000000000000000000000000000 * m^2 ; -: Ci ( n -- curie ) 37000000000 * Bq ; -: R ( -- dimensioned ) 258/10000 { s A } { kg } ; -: rad ( n -- dimensioned ) 100 / Gy ; - -! roentgen equivalent man, equal to one roentgen of X-rays -: roentgen-equivalent-man ( n -- dimensioned ) 100 / Sv ; - -! inaccurate, use calendar where possible -: minutes ( n -- dimensioned ) 60 * s ; -: hours ( n -- dimensioned ) 60 * minutes ; -: days ( n -- dimensioned ) 24 * hours ; - -! Y Z E P T G M k h da 1 d c m mu n p f a z y -: yotta ( n -- x ) 1000000000000000000000000 * ; -: zetta ( n -- x ) 1000000000000000000000 * ; -: exa ( n -- x ) 1000000000000000000 * ; -: peta ( n -- x ) 1000000000000000 * ; -: tera ( n -- x ) 1000000000000 * ; -: giga ( n -- x ) 1000000000 * ; -: mega ( n -- x ) 1000000 * ; -: kilo ( n -- x ) 1000 * ; -: hecto ( n -- x ) 100 * ; -: deca ( n -- x ) 10 * ; -: deci ( n -- x ) 10 / ; -: centi ( n -- x ) 100 / ; -: milli ( n -- x ) 1000 / ; -: micro ( n -- x ) 1000000 / ; -: nano ( n -- x ) 1000000000 / ; -: pico ( n -- x ) 1000000000000 / ; -: femto ( n -- x ) 1000000000000000 / ; -: atto ( n -- x ) 1000000000000000000 / ; -: zepto ( n -- x ) 1000000000000000000000 / ; -: yocto ( n -- x ) 1000000000000000000000000 / ; - -: km ( n -- dimensioned ) kilo m ; -: cm ( n -- dimensioned ) centi m ; -: mm ( n -- dimensioned ) milli m ; -: nm ( n -- dimensioned ) nano m ; -: g ( n -- dimensioned ) milli kg ; -: ms ( n -- dimensioned ) milli s ; -: angstrom ( n -- dimensioned ) 10 / nm ; diff --git a/basis/units/units-tests.factor b/basis/units/units-tests.factor deleted file mode 100755 index 9b450ed18b..0000000000 --- a/basis/units/units-tests.factor +++ /dev/null @@ -1,21 +0,0 @@ -USING: arrays kernel math sequences tools.test units.si -units.imperial units inverse math.functions ; -IN: units.tests - -[ T{ dimensioned f 3 { m } { } } ] [ 3 m ] unit-test -[ T{ dimensioned f 3 { m } { s } } ] [ 3 m/s ] unit-test -[ T{ dimensioned f 4000 { m } { } } ] [ 4 km ] unit-test - -[ t ] [ 4 m 5 m d+ 9 m = ] unit-test -[ t ] [ 5 m 1 m d- 4 m = ] unit-test -[ t ] [ 5 m 2 m d* 10 m^2 = ] unit-test -[ t ] [ 5 m 2 m d/ 5/2 { } { } = ] unit-test -[ t ] [ 5 m 2 m tuck d/ drop 2 m = ] unit-test - -[ t ] [ 1 m 2 m 3 m 3array d-product 6 m^3 = ] unit-test -[ t ] [ 3 m d-recip 1/3 { } { m } = ] unit-test - -: km/L km 1 L d/ ; -: mpg miles 1 gallons d/ ; - -[ t ] [ 100 10 / km/L [ mpg ] undo 23 1 ~ ] unit-test diff --git a/basis/units/units.factor b/basis/units/units.factor deleted file mode 100755 index 7604108b82..0000000000 --- a/basis/units/units.factor +++ /dev/null @@ -1,102 +0,0 @@ -USING: accessors arrays io kernel math namespaces splitting -prettyprint sequences sorting vectors words inverse summary -shuffle math.functions sets ; -IN: units - -TUPLE: dimensioned value top bot ; - -TUPLE: dimensions-not-equal ; - -: dimensions-not-equal ( -- * ) - \ dimensions-not-equal new throw ; - -M: dimensions-not-equal summary drop "Dimensions do not match" ; - -: remove-one ( seq obj -- seq ) - 1array split1 append ; - -: 2remove-one ( seq seq obj -- seq seq ) - [ remove-one ] curry bi@ ; - -: symbolic-reduce ( seq seq -- seq seq ) - 2dup intersect dup empty? - [ drop ] [ first 2remove-one symbolic-reduce ] if ; - -: ( n top bot -- obj ) - symbolic-reduce - [ natural-sort ] bi@ - dimensioned boa ; - -: >dimensioned< ( d -- n top bot ) - [ value>> ] [ top>> ] [ bot>> ] tri ; - -\ [ >dimensioned< ] define-inverse - -: dimensions ( dimensioned -- top bot ) - [ top>> ] [ bot>> ] bi ; - -: check-dimensions ( d d -- ) - [ dimensions 2array ] bi@ = - [ dimensions-not-equal ] unless ; - -: 2values ( dim dim -- val val ) [ value>> ] bi@ ; - -: ( top bot val -- dim ) - -rot ; - -: d+ ( d d -- d ) ; - -: d- ( d d -- d ) ; - -: scalar ( n -- d ) - { } { } ; - -: d* ( d d -- d ) - [ dup number? [ scalar ] when ] bi@ - [ [ top>> ] bi@ append ] 2keep - [ [ bot>> ] bi@ append ] 2keep - 2values * dimension-op> ; - -: d-neg ( d -- d ) -1 d* ; - -: d-sq ( d -- d ) dup d* ; - -: d-recip ( d -- d' ) - >dimensioned< spin recip dimension-op> ; - -: d/ ( d d -- d ) d-recip d* ; - -: comparison-op ( d d -- n n ) 2dup check-dimensions 2values ; - -: d< ( d d -- ? ) comparison-op < ; - -: d<= ( d d -- ? ) comparison-op <= ; - -: d> ( d d -- ? ) comparison-op > ; - -: d>= ( d d -- ? ) comparison-op >= ; - -: d= ( d d -- ? ) comparison-op number= ; - -: d~ ( d d delta -- ? ) >r comparison-op r> ~ ; - -: d-min ( d d -- d ) [ d< ] most ; - -: d-max ( d d -- d ) [ d> ] most ; - -: d-product ( v -- d ) 1 scalar [ d* ] reduce ; - -: d-sum ( v -- d ) unclip-slice [ d+ ] reduce ; - -: d-infimum ( v -- d ) unclip-slice [ d-min ] reduce ; - -: d-supremum ( v -- d ) unclip-slice [ d-max ] reduce ; - -\ d+ [ d- ] [ d- ] define-math-inverse -\ d- [ d+ ] [ d- ] define-math-inverse -\ d* [ d/ ] [ d/ ] define-math-inverse -\ d/ [ d* ] [ d/ ] define-math-inverse -\ d-recip [ d-recip ] define-inverse diff --git a/basis/unix/linux/inotify/inotify.factor b/basis/unix/linux/inotify/inotify.factor index f94dc74ab9..3385e454d2 100644 --- a/basis/unix/linux/inotify/inotify.factor +++ b/basis/unix/linux/inotify/inotify.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.syntax math math.bitfields ; +USING: alien.syntax math math.bitwise ; IN: unix.linux.inotify C-STRUCT: inotify-event diff --git a/basis/validators/validators.factor b/basis/validators/validators.factor index 37c0216740..b786ef5529 100644 --- a/basis/validators/validators.factor +++ b/basis/validators/validators.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2006, 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. -USING: kernel continuations sequences sequences.lib math +USING: kernel continuations sequences math namespaces sets math.parser math.ranges assocs regexp unicode.categories arrays hashtables words classes quotations xmode.catalog ; diff --git a/basis/windows/advapi32/advapi32.factor b/basis/windows/advapi32/advapi32.factor index b7381968a5..251b59a4d8 100755 --- a/basis/windows/advapi32/advapi32.factor +++ b/basis/windows/advapi32/advapi32.factor @@ -1,4 +1,4 @@ -USING: alias alien.syntax kernel math windows.types math.bitfields ; +USING: alias alien.syntax kernel math windows.types math.bitwise ; IN: windows.advapi32 LIBRARY: advapi32 diff --git a/basis/windows/opengl32/opengl32.factor b/basis/windows/opengl32/opengl32.factor index ca2206eac4..df09d9327a 100755 --- a/basis/windows/opengl32/opengl32.factor +++ b/basis/windows/opengl32/opengl32.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2005, 2006 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.c-types alien.syntax parser namespaces kernel -math math.bitfields windows.types windows.types init assocs +math math.bitwise windows.types windows.types init assocs sequences libc ; IN: windows.opengl32 diff --git a/basis/windows/user32/user32.factor b/basis/windows/user32/user32.factor index 481f00f36b..e5c9f96275 100755 --- a/basis/windows/user32/user32.factor +++ b/basis/windows/user32/user32.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2005, 2006 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.syntax parser namespaces kernel math -windows.types generalizations math.bitfields alias ; +windows.types generalizations math.bitwise alias ; IN: windows.user32 ! HKL for ActivateKeyboardLayout diff --git a/basis/windows/winsock/winsock.factor b/basis/windows/winsock/winsock.factor index 303aefeb5f..3c4230e21e 100755 --- a/basis/windows/winsock/winsock.factor +++ b/basis/windows/winsock/winsock.factor @@ -2,7 +2,7 @@ USING: alien alien.c-types alien.strings alien.syntax arrays byte-arrays kernel math sequences windows.types windows.kernel32 -windows.errors structs windows math.bitfields alias ; +windows.errors structs windows math.bitwise alias ; IN: windows.winsock USE: libc diff --git a/basis/x11/windows/windows.factor b/basis/x11/windows/windows.factor index f9158c2956..aed45655f6 100755 --- a/basis/x11/windows/windows.factor +++ b/basis/x11/windows/windows.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2005, 2006 Eduardo Cavazos and Slava Pestov ! See http://factorcode.org/license.txt for BSD license. -USING: alien alien.c-types hashtables kernel math math.vectors math.bitfields -namespaces sequences x11.xlib x11.constants x11.glx ; +USING: alien alien.c-types hashtables kernel math math.vectors +math.bitwise namespaces sequences x11.xlib x11.constants x11.glx ; IN: x11.windows : create-window-mask ( -- n ) diff --git a/basis/x11/xlib/xlib.factor b/basis/x11/xlib/xlib.factor index 6fc586106c..eecf427c9e 100755 --- a/basis/x11/xlib/xlib.factor +++ b/basis/x11/xlib/xlib.factor @@ -12,7 +12,7 @@ ! and note the section. USING: kernel arrays alien alien.c-types alien.strings -alien.syntax math math.bitfields words sequences namespaces +alien.syntax math math.bitwise words sequences namespaces continuations io.encodings.ascii ; IN: x11.xlib diff --git a/basis/xml/generator/generator.factor b/basis/xml/generator/generator.factor index d5cf4dac40..0de1692e00 100644 --- a/basis/xml/generator/generator.factor +++ b/basis/xml/generator/generator.factor @@ -1,7 +1,6 @@ ! Copyright (C) 2006, 2007 Daniel Ehrenberg ! See http://factorcode.org/license.txt for BSD license. -USING: namespaces kernel xml.data xml.utilities assocs splitting -sequences parser lexer quotations sequences.lib xml.utilities ; +USING: namespaces kernel xml.data xml.utilities assocs sequences ; IN: xml.generator : comment, ( string -- ) , ; @@ -24,56 +23,3 @@ IN: xml.generator (tag,) build-xml ; inline : make-xml ( name quot -- xml ) f swap make-xml* ; inline - -! Word-based XML literal syntax -: parsed-name ( accum -- accum ) - scan ":" split1 [ f ] [ ] if* parsed ; - -: run-combinator ( accum quot1 quot2 -- accum ) - >r [ ] like parsed r> [ parsed ] each ; - -: parse-tag-contents ( accum contained? -- accum ) - [ \ contained*, parsed ] [ - scan-word \ [ = - [ POSTPONE: [ \ tag*, parsed ] - [ "Expected [ missing" throw ] if - ] if ; - -DEFER: >> - -: attributes-parsed ( accum quot -- accum ) - dup empty? [ drop f parsed ] [ - >r \ >r parsed r> parsed - [ H{ } make-assoc r> swap ] [ parsed ] each - ] if ; - -: << - parsed-name [ - \ >> parse-until >quotation - attributes-parsed \ contained? get - ] with-scope parse-tag-contents ; parsing - -: == - \ call parsed parsed-name \ set parsed ; parsing - -: // - \ contained? on ; parsing - -: parse-special ( accum end-token word -- accum ) - >r parse-tokens " " join parsed r> parsed ; - -: " \ comment, parse-special ; parsing - -: " \ directive, parse-special ; parsing - -: " \ instruction, parse-special ; parsing - -: >xml-document ( seq -- xml ) - dup first prolog? [ unclip-slice ] [ standard-prolog ] if swap - [ tag? ] split-around ; - -DEFER: XML> - -: [ >quotation ] parse-literal - { } parsed \ make parsed \ >xml-document parsed ; parsing diff --git a/basis/xmode/marker/marker.factor b/basis/xmode/marker/marker.factor index f11ac6b5b2..dfdd6c801a 100755 --- a/basis/xmode/marker/marker.factor +++ b/basis/xmode/marker/marker.factor @@ -1,7 +1,7 @@ IN: xmode.marker USING: kernel namespaces xmode.rules xmode.tokens xmode.marker.state xmode.marker.context xmode.utilities -xmode.catalog sequences math assocs combinators combinators.lib +xmode.catalog sequences math assocs combinators strings regexp splitting parser-combinators ascii unicode.case combinators.short-circuit accessors ; diff --git a/core/sequences/sequences-docs.factor b/core/sequences/sequences-docs.factor index 1bcd01d9b9..baf68db112 100755 --- a/core/sequences/sequences-docs.factor +++ b/core/sequences/sequences-docs.factor @@ -315,6 +315,15 @@ HELP: empty? { $values { "seq" sequence } { "?" "a boolean" } } { $description "Tests if the sequence has zero length." } ; +HELP: if-empty +{ $values { "seq" sequence } { "quot1" quotation } { "quot2" quotation } } +{ $description "Makes an implicit check if the sequence is empty. An empty sequence is dropped and " { $snippet "quot1" } " is called. Otherwise, if the sequence has any elements, " { $snippet "quot2" } " is called on it." } +{ $example + "USING: kernel prettyprint sequences sequences.lib ;" + "{ 1 2 3 } [ \"empty sequence\" ] [ sum ] if-empty ." + "6" +} ; + HELP: delete-all { $values { "seq" "a resizable sequence" } } { $description "Resizes the sequence to zero length, removing all elements. Not all sequences are resizable." } diff --git a/core/sequences/sequences-tests.factor b/core/sequences/sequences-tests.factor index 4b7b8a3151..fa5a3aecfb 100755 --- a/core/sequences/sequences-tests.factor +++ b/core/sequences/sequences-tests.factor @@ -3,6 +3,9 @@ sequences.private strings sbufs tools.test vectors generic vocabs.loader ; IN: sequences.tests +[ "empty" ] [ { } [ "empty" ] [ "not empty" ] if-empty ] unit-test +[ { 1 } "not empty" ] [ { 1 } [ "empty" ] [ "not empty" ] if-empty ] unit-test + [ V{ 1 2 3 4 } ] [ 1 5 dup >vector ] unit-test [ 3 ] [ 1 4 dup length ] unit-test [ 2 ] [ 1 3 { 1 2 3 4 } length ] unit-test diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index 73c9289415..c70d15701e 100755 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -28,6 +28,14 @@ M: sequence lengthen 2dup length > [ set-length ] [ 2drop ] if ; M: sequence shorten 2dup length < [ set-length ] [ 2drop ] if ; : empty? ( seq -- ? ) length zero? ; inline + +: if-empty ( seq quot1 quot2 -- ) + [ dup empty? ] [ [ drop ] prepose ] [ ] tri* if ; inline + +: when-empty ( seq quot1 -- ) [ ] if-empty ; inline + +: unless-empty ( seq quot1 -- ) [ ] swap if-empty ; inline + : delete-all ( seq -- ) 0 swap set-length ; : first ( seq -- first ) 0 swap nth ; inline @@ -582,6 +590,9 @@ M: slice equal? over slice? [ sequence= ] [ 2drop f ] if ; [ >r >r dup pick length + r> - over r> open-slice ] keep copy ; +: remove-nth ( n seq -- seq' ) + [ swap head-slice ] [ swap 1+ tail-slice ] 2bi append ; + : pop ( seq -- elt ) [ length 1- ] [ [ nth ] [ shorten ] 2bi ] bi ; @@ -659,6 +670,9 @@ M: slice equal? over slice? [ sequence= ] [ 2drop f ] if ; : cut-slice ( seq n -- before after ) [ head-slice ] [ tail-slice ] 2bi ; +: insert-nth ( elt n seq -- seq' ) + swap cut-slice [ swap suffix ] dip append ; + : midpoint@ ( seq -- n ) length 2/ ; inline : halves ( seq -- first second ) diff --git a/extra/crypto/common/common.factor b/extra/crypto/common/common.factor index 651bd51774..61cc11f959 100644 --- a/extra/crypto/common/common.factor +++ b/extra/crypto/common/common.factor @@ -1,55 +1,17 @@ USING: arrays kernel io io.binary sbufs splitting grouping strings sequences namespaces math math.parser parser -hints math.bitfields.lib assocs ; +hints math.bitwise assocs ; IN: crypto.common -: w+ ( int int -- int ) + 32 bits ; inline - : (nth-int) ( string n -- int ) 2 shift dup 4 + rot ; inline : nth-int ( string n -- int ) (nth-int) le> ; inline -: nth-int-be ( string n -- int ) (nth-int) be> ; inline - : update ( num var -- ) [ w+ ] change ; inline - -: calculate-pad-length ( length -- pad-length ) - dup 56 < 55 119 ? swap - ; -: preprocess-plaintext ( string big-endian? -- padded-string ) - #! pad 0x80 then 00 til 8 bytes left, then 64bit length in bits - >r >sbuf r> over [ - HEX: 80 , - dup length HEX: 3f bitand - calculate-pad-length 0 % - length 3 shift 8 rot [ >be ] [ >le ] if % - ] "" make over push-all ; - -SYMBOL: bytes-read SYMBOL: big-endian? -: pad-last-block ( str big-endian? length -- str ) - [ - rot % - HEX: 80 , - dup HEX: 3f bitand calculate-pad-length 0 % - 3 shift 8 rot [ >be ] [ >le ] if % - ] "" make 64 group ; - -: update-old-new ( old new -- ) - [ get >r get r> ] 2keep >r >r w+ dup r> set r> set ; inline - -: slice3 ( n seq -- a b c ) >r dup 3 + r> first3 ; - -: seq>2seq ( seq -- seq1 seq2 ) - #! { abcdefgh } -> { aceg } { bdfh } - 2 group flip dup empty? [ drop { } { } ] [ first2 ] if ; - -: 2seq>seq ( seq1 seq2 -- seq ) - #! { aceg } { bdfh } -> { abcdefgh } - [ zip concat ] keep like ; - : mod-nth ( n seq -- elt ) #! 5 "abcd" -> b [ length mod ] [ nth ] bi ; diff --git a/extra/html/parser/analyzer/analyzer.factor b/extra/html/parser/analyzer/analyzer.factor new file mode 100755 index 0000000000..29ccc345d3 --- /dev/null +++ b/extra/html/parser/analyzer/analyzer.factor @@ -0,0 +1,182 @@ +USING: assocs html.parser kernel math sequences strings ascii +arrays generalizations shuffle unicode.case namespaces splitting +http sequences.lib accessors io combinators http.client urls ; +IN: html.parser.analyzer + +TUPLE: link attributes clickable ; + +: scrape-html ( url -- vector ) + http-get nip parse-html ; + +: (find-relative) + [ >r + dup r> ?nth* [ 2drop f f ] unless ] [ 2drop f ] if ; inline + +: find-relative ( seq quot n -- i elt ) + >r over [ find drop ] dip r> swap pick + (find-relative) ; inline + +: (find-all) ( n seq quot -- ) + 2dup >r >r find-from [ + dupd 2array , 1+ r> r> (find-all) + ] [ + r> r> 3drop + ] if* ; inline + +: find-all ( seq quot -- alist ) + [ 0 -rot (find-all) ] { } make ; inline + +: (find-nth) ( offset seq quot n count -- obj ) + >r >r [ find-from ] 2keep 4 npick [ + r> r> 1+ 2dup <= [ + 4drop + ] [ + >r >r >r >r drop 1+ r> r> r> r> + (find-nth) + ] if + ] [ + 2drop r> r> 2drop + ] if ; inline + +: find-nth ( seq quot n -- i elt ) + 0 -roll 0 (find-nth) ; inline + +: find-nth-relative ( seq quot n offest -- i elt ) + >r [ find-nth ] 3keep 2drop nip r> swap pick + (find-relative) ; inline + +: remove-blank-text ( vector -- vector' ) + [ + dup name>> text = [ + text>> [ blank? ] all? not + ] [ + drop t + ] if + ] filter ; + +: trim-text ( vector -- vector' ) + [ + dup name>> text = [ + [ [ blank? ] trim ] change-text + ] when + ] map ; + +: find-by-id ( id vector -- vector ) + [ attributes>> "id" swap at = ] with filter ; + +: find-by-class ( id vector -- vector ) + [ attributes>> "class" swap at = ] with filter ; + +: find-by-name ( str vector -- vector ) + >r >lower r> + [ name>> = ] with filter ; + +: find-first-name ( str vector -- i/f tag/f ) + >r >lower r> + [ name>> = ] with find ; + +: find-matching-close ( str vector -- i/f tag/f ) + >r >lower r> + [ [ name>> = ] keep closing?>> and ] with find ; + +: find-by-attribute-key ( key vector -- vector ) + >r >lower r> + [ attributes>> at ] with filter + sift ; + +: find-by-attribute-key-value ( value key vector -- vector ) + >r >lower r> + [ attributes>> at over = ] with filter nip + sift ; + +: find-first-attribute-key-value ( value key vector -- i/f tag/f ) + >r >lower r> + [ attributes>> at over = ] with find rot drop ; + +: find-between* ( i/f tag/f vector -- vector ) + pick integer? [ + rot tail-slice + >r name>> r> + [ find-matching-close drop dup [ 1+ ] when ] keep + swap [ head ] [ first ] if* + ] [ + 3drop V{ } clone + ] if ; + +: find-between ( i/f tag/f vector -- vector ) + find-between* dup length 3 >= [ + [ rest-slice but-last-slice ] keep like + ] when ; + +: find-between-first ( string vector -- vector' ) + [ find-first-name ] keep find-between ; + +: find-between-all ( vector quot -- seq ) + [ [ [ closing?>> not ] bi and ] curry find-all ] curry + [ [ >r first2 r> find-between* ] curry map ] bi ; + +: tag-link ( tag -- link/f ) + attributes>> [ "href" swap at ] [ f ] if* ; + +: find-links ( vector -- vector' ) + [ [ name>> "a" = ] [ attributes>> "href" swap at ] bi and ] + find-between-all ; + +: ( vector -- link ) + [ first attributes>> ] + [ [ name>> { text "img" } member? ] filter ] bi + link boa ; + +: link. ( vector -- ) + [ attributes>> "href" swap at write nl ] + [ clickable>> [ bl bl text>> print ] each nl ] bi ; + +: find-by-text ( seq quot -- tag ) + [ dup name>> text = ] prepose find drop ; + +: find-opening-tags-by-name ( name seq -- seq ) + [ [ name>> = ] keep closing?>> not and ] with find-all ; + +: href-contains? ( str tag -- ? ) + attributes>> "href" swap at* [ subseq? ] [ 2drop f ] if ; + +: find-hrefs ( vector -- vector' ) + find-links + [ [ + [ name>> "a" = ] + [ attributes>> "href" swap key? ] bi and ] filter + ] map sift [ [ attributes>> "href" swap at ] map ] map concat ; + +: find-forms ( vector -- vector' ) + "form" over find-opening-tags-by-name + swap [ >r first2 r> find-between* ] curry map + [ [ name>> { "form" "input" } member? ] filter ] map ; + +: find-html-objects ( string vector -- vector' ) + [ find-opening-tags-by-name ] keep + [ >r first2 r> find-between* ] curry map ; + +: form-action ( vector -- string ) + [ name>> "form" = ] find nip + attributes>> "action" swap at ; + +: hidden-form-values ( vector -- strings ) + [ attributes>> "type" swap at "hidden" = ] filter ; + +: input. ( tag -- ) + dup name>> print + attributes>> + [ bl bl bl bl [ write "=" write ] [ write bl ] bi* nl ] assoc-each ; + +: form. ( vector -- ) + [ closing?>> not ] filter + [ + { + { [ dup name>> "form" = ] + [ "form action: " write attributes>> "action" swap at print ] } + { [ dup name>> "input" = ] [ input. ] } + [ drop ] + } cond + ] each ; + +: query>assoc* ( str -- hash ) + "?" split1 nip query>assoc ; diff --git a/extra/html/parser/analyzer/authors.txt b/extra/html/parser/analyzer/authors.txt new file mode 100755 index 0000000000..7c1b2f2279 --- /dev/null +++ b/extra/html/parser/analyzer/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/extra/html/parser/authors.txt b/extra/html/parser/authors.txt new file mode 100755 index 0000000000..7c1b2f2279 --- /dev/null +++ b/extra/html/parser/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/extra/html/parser/parser-tests.factor b/extra/html/parser/parser-tests.factor new file mode 100644 index 0000000000..9757f70a67 --- /dev/null +++ b/extra/html/parser/parser-tests.factor @@ -0,0 +1,62 @@ +USING: html.parser kernel tools.test ; +IN: html.parser.tests + +[ + V{ T{ tag f "html" H{ } f f } } +] [ "" parse-html ] unit-test + +[ + V{ T{ tag f "html" H{ } f t } } +] [ "" parse-html ] unit-test + +[ + V{ T{ tag f "a" H{ { "href" "http://factorcode.org/" } } f f } } +] [ "" parse-html ] unit-test + +[ + V{ T{ tag f "a" H{ { "href" "http://factorcode.org/" } } f f } } +] [ "" parse-html ] unit-test + +[ +V{ + T{ + tag + f + "a" + H{ { "baz" "\"quux\"" } { "foo" "bar's" } } + f + f + } +} +] [ "" parse-html ] unit-test + +[ +V{ + T{ tag f "a" + H{ + { "a" "pirsqd" } + { "foo" "bar" } + { "href" "http://factorcode.org/" } + { "baz" "quux" } + } f f } +} +] [ "" parse-html ] unit-test + +[ +V{ + T{ tag f "html" H{ } f f } + T{ tag f "head" H{ } f f } + T{ tag f "head" H{ } f t } + T{ tag f "html" H{ } f t } +} +] [ "Spagna ( name attributes closing? -- tag ) + tag new + swap >>closing? + swap >>attributes + swap >>name ; + +: make-tag ( string attribs -- tag ) + >r [ closing-tag? ] keep "/" trim1 r> rot ; + +: make-text-tag ( string -- tag ) + tag new + text >>name + swap >>text ; + +: make-comment-tag ( string -- tag ) + tag new + comment >>name + swap >>text ; + +: make-dtd-tag ( string -- tag ) + tag new + dtd >>name + swap >>text ; + +: read-whitespace ( -- string ) + [ get-char blank? not ] take-until ; + +: read-whitespace* ( -- ) read-whitespace drop ; + +: read-token ( -- string ) + read-whitespace* + [ get-char blank? ] take-until ; + +: read-single-quote ( -- string ) + [ get-char CHAR: ' = ] take-until ; + +: read-double-quote ( -- string ) + [ get-char CHAR: " = ] take-until ; + +: read-quote ( -- string ) + get-char next* CHAR: ' = + [ read-single-quote ] [ read-double-quote ] if next* ; + +: read-key ( -- string ) + read-whitespace* + [ get-char [ CHAR: = = ] [ blank? ] bi or ] take-until ; + +: read-= ( -- ) + read-whitespace* + [ get-char CHAR: = = ] take-until drop next* ; + +: read-value ( -- string ) + read-whitespace* + get-char quote? [ read-quote ] [ read-token ] if + [ blank? ] trim ; + +: read-comment ( -- ) + "-->" take-string* make-comment-tag push-tag ; + +: read-dtd ( -- ) + ">" take-string* make-dtd-tag push-tag ; + +: read-bang ( -- ) + next* get-char CHAR: - = get-next CHAR: - = and [ + next* next* + read-comment + ] [ + read-dtd + ] if ; + +: read-tag ( -- string ) + [ get-char CHAR: > = get-char CHAR: < = or ] take-until + get-char CHAR: < = [ next* ] unless ; + +: read-< ( -- string ) + next* get-char CHAR: ! = [ + read-bang f + ] [ + read-tag + ] if ; + +: read-until-< ( -- string ) + [ get-char CHAR: < = ] take-until ; + +: parse-text ( -- ) + read-until-< dup empty? [ + drop + ] [ + make-text-tag push-tag + ] if ; + +: (parse-attributes) ( -- ) + read-whitespace* + string-parse-end? [ + read-key >lower read-= read-value + 2array , (parse-attributes) + ] unless ; + +: parse-attributes ( -- hashtable ) + [ (parse-attributes) ] { } make >hashtable ; + +: (parse-tag) ( string -- string' hashtable ) + [ + read-token >lower + parse-attributes + ] string-parse ; + +: parse-tag ( -- ) + read-< [ + (parse-tag) make-tag push-tag + ] unless-empty ; + +: (parse-html) ( -- ) + get-next [ + parse-text + parse-tag + (parse-html) + ] when ; + +: tag-parse ( quot -- vector ) + V{ } clone tagstack [ string-parse ] with-variable ; + +: parse-html ( string -- vector ) + [ (parse-html) tagstack get ] tag-parse ; diff --git a/extra/html/parser/printer/authors.txt b/extra/html/parser/printer/authors.txt new file mode 100755 index 0000000000..7c1b2f2279 --- /dev/null +++ b/extra/html/parser/printer/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/extra/html/parser/printer/printer.factor b/extra/html/parser/printer/printer.factor new file mode 100644 index 0000000000..4419eec70e --- /dev/null +++ b/extra/html/parser/printer/printer.factor @@ -0,0 +1,89 @@ +USING: accessors assocs html.parser html.parser.utils combinators +continuations hashtables +hashtables.private io kernel math +namespaces prettyprint quotations sequences splitting +strings ; +IN: html.parser.printer + +SYMBOL: printer + +TUPLE: html-printer ; +TUPLE: text-printer < html-printer ; +TUPLE: src-printer < html-printer ; +TUPLE: html-prettyprinter < html-printer ; + +HOOK: print-text-tag html-printer ( tag -- ) +HOOK: print-comment-tag html-printer ( tag -- ) +HOOK: print-dtd-tag html-printer ( tag -- ) +HOOK: print-opening-tag html-printer ( tag -- ) +HOOK: print-closing-tag html-printer ( tag -- ) + +ERROR: unknown-tag-error tag ; + +: print-tag ( tag -- ) + { + { [ dup name>> text = ] [ print-text-tag ] } + { [ dup name>> comment = ] [ print-comment-tag ] } + { [ dup name>> dtd = ] [ print-dtd-tag ] } + { [ dup [ name>> string? ] [ closing?>> ] bi and ] + [ print-closing-tag ] } + { [ dup name>> string? ] + [ print-opening-tag ] } + [ unknown-tag-error ] + } cond ; + +: print-tags ( vector -- ) [ print-tag ] each ; + +: html-text. ( vector -- ) + T{ text-printer } html-printer [ print-tags ] with-variable ; + +: html-src. ( vector -- ) + T{ src-printer } html-printer [ print-tags ] with-variable ; + +M: html-printer print-text-tag ( tag -- ) text>> write ; + +M: html-printer print-comment-tag ( tag -- ) + "" write ; + +M: html-printer print-dtd-tag ( tag -- ) + "> write ">" write ; + +: print-attributes ( hashtable -- ) + [ [ bl write "=" write ] [ ?quote write ] bi* ] assoc-each ; + +M: src-printer print-opening-tag ( tag -- ) + "<" write + [ name>> write ] + [ attributes>> dup assoc-empty? [ drop ] [ print-attributes ] if ] bi + ">" write ; + +M: src-printer print-closing-tag ( tag -- ) + "> write + ">" write ; + +SYMBOL: tab-width +SYMBOL: #indentations +SYMBOL: tagstack + +: prettyprint-html ( vector -- ) + [ + T{ html-prettyprinter } printer set + V{ } clone tagstack set + 2 tab-width set + 0 #indentations set + print-tags + ] with-scope ; + +: print-tabs ( -- ) + tab-width get #indentations get * CHAR: \s write ; + +M: html-prettyprinter print-opening-tag ( tag -- ) + print-tabs "<" write + name>> write + ">\n" write ; + +M: html-prettyprinter print-closing-tag ( tag -- ) + "> write + ">" write ; diff --git a/extra/html/parser/utils/authors.txt b/extra/html/parser/utils/authors.txt new file mode 100755 index 0000000000..7c1b2f2279 --- /dev/null +++ b/extra/html/parser/utils/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/extra/html/parser/utils/utils-tests.factor b/extra/html/parser/utils/utils-tests.factor new file mode 100644 index 0000000000..4b25db16fd --- /dev/null +++ b/extra/html/parser/utils/utils-tests.factor @@ -0,0 +1,24 @@ +USING: assocs combinators continuations hashtables +hashtables.private io kernel math +namespaces prettyprint quotations sequences splitting +state-parser strings tools.test ; +USING: html.parser.utils ; +IN: html.parser.utils.tests + +[ "'Rome'" ] [ "Rome" single-quote ] unit-test +[ "\"Roma\"" ] [ "Roma" double-quote ] unit-test +[ "'Firenze'" ] [ "Firenze" quote ] unit-test +[ "\"Caesar's\"" ] [ "Caesar's" quote ] unit-test +[ f ] [ "" quoted? ] unit-test +[ t ] [ "''" quoted? ] unit-test +[ t ] [ "\"\"" quoted? ] unit-test +[ t ] [ "\"Circus Maximus\"" quoted? ] unit-test +[ t ] [ "'Circus Maximus'" quoted? ] unit-test +[ f ] [ "Circus Maximus" quoted? ] unit-test +[ "'Italy'" ] [ "Italy" ?quote ] unit-test +[ "'Italy'" ] [ "'Italy'" ?quote ] unit-test +[ "\"Italy\"" ] [ "\"Italy\"" ?quote ] unit-test +[ "Italy" ] [ "Italy" unquote ] unit-test +[ "Italy" ] [ "'Italy'" unquote ] unit-test +[ "Italy" ] [ "\"Italy\"" unquote ] unit-test + diff --git a/extra/html/parser/utils/utils.factor b/extra/html/parser/utils/utils.factor new file mode 100644 index 0000000000..04b3687f7d --- /dev/null +++ b/extra/html/parser/utils/utils.factor @@ -0,0 +1,37 @@ +USING: assocs circular combinators continuations hashtables +hashtables.private io kernel math +namespaces prettyprint quotations sequences splitting +state-parser strings sequences.lib ; +IN: html.parser.utils + +: string-parse-end? ( -- ? ) get-next not ; + +: take-string* ( match -- string ) + dup length + [ 2dup string-matches? ] take-until nip + dup length rot length 1- - head next* ; + +: trim1 ( seq ch -- newseq ) + [ ?head drop ] [ ?tail drop ] bi ; + +: single-quote ( str -- newstr ) + "'" swap "'" 3append ; + +: double-quote ( str -- newstr ) + "\"" swap "\"" 3append ; + +: quote ( str -- newstr ) + CHAR: ' over member? + [ double-quote ] [ single-quote ] if ; + +: quoted? ( str -- ? ) + [ f ] + [ [ first ] [ peek ] bi [ = ] keep "'\"" member? and ] if-empty ; + +: ?quote ( str -- newstr ) + dup quoted? [ quote ] unless ; + +: unquote ( str -- newstr ) + dup quoted? [ but-last-slice rest-slice >string ] when ; + +: quote? ( ch -- ? ) "'\"" member? ; diff --git a/extra/io/files/unique/unique.factor b/extra/io/files/unique/unique.factor index 3efef66ae3..db11471a7a 100644 --- a/extra/io/files/unique/unique.factor +++ b/extra/io/files/unique/unique.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel math math.bitfields combinators.lib math.parser +USING: kernel math math.bitwise combinators.lib math.parser random sequences sequences.lib continuations namespaces io.files io arrays io.files.unique.backend system combinators vocabs.loader ; diff --git a/extra/io/serial/serial.factor b/extra/io/serial/serial.factor index c24f08906c..936bc182bc 100644 --- a/extra/io/serial/serial.factor +++ b/extra/io/serial/serial.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: accessors alien.c-types assocs combinators destructors -kernel math math.bitfields math.parser sequences summary system +kernel math math.bitwise math.parser sequences summary system vocabs.loader ; IN: io.serial diff --git a/extra/io/serial/unix/bsd/bsd.factor b/extra/io/serial/unix/bsd/bsd.factor index 3c5ce62c63..b684190698 100644 --- a/extra/io/serial/unix/bsd/bsd.factor +++ b/extra/io/serial/unix/bsd/bsd.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.syntax kernel math.bitfields sequences system io.serial ; +USING: alien.syntax kernel math.bitwise sequences system io.serial ; IN: io.serial.unix M: bsd lookup-baud ( m -- n ) diff --git a/extra/io/serial/unix/unix-tests.factor b/extra/io/serial/unix/unix-tests.factor index bbfd10b943..6dd056feb5 100644 --- a/extra/io/serial/unix/unix-tests.factor +++ b/extra/io/serial/unix/unix-tests.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors kernel math.bitfields serial serial.unix ; +USING: accessors kernel math.bitwise serial serial.unix ; IN: io.serial.unix : serial-obj ( -- obj ) diff --git a/extra/io/serial/unix/unix.factor b/extra/io/serial/unix/unix.factor index ed60d941dd..1da6385f96 100644 --- a/extra/io/serial/unix/unix.factor +++ b/extra/io/serial/unix/unix.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: accessors alien.c-types alien.syntax combinators io.ports -io.streams.duplex io.unix.backend system kernel math math.bitfields +io.streams.duplex io.unix.backend system kernel math math.bitwise vocabs.loader unix io.serial io.serial.unix.termios ; IN: io.serial.unix diff --git a/extra/math/bit-count/bit-count.factor b/extra/math/bit-count/bit-count.factor deleted file mode 100644 index f5b0cc53df..0000000000 --- a/extra/math/bit-count/bit-count.factor +++ /dev/null @@ -1,38 +0,0 @@ -! Copyright (C) 2008 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: kernel math math.functions quotations words sequences -sequences.private combinators fry ; -IN: math.bit-count - -> - -GENERIC: (bit-count) ( x -- n ) - -M: fixnum (bit-count) - { - [ byte-bit-count ] - [ -8 shift byte-bit-count ] - [ -16 shift byte-bit-count ] - [ -24 shift byte-bit-count ] - } cleave + + + ; - -M: bignum (bit-count) - dup 0 = [ drop 0 ] [ - [ byte-bit-count ] [ -8 shift (bit-count) ] bi + - ] if ; - -PRIVATE> - -: bit-count ( x -- n ) - dup 0 >= [ (bit-count) ] [ bitnot (bit-count) ] if ; inline diff --git a/extra/math/bitfields/lib/lib-docs.factor b/extra/math/bitfields/lib/lib-docs.factor deleted file mode 100644 index bfbe9eaded..0000000000 --- a/extra/math/bitfields/lib/lib-docs.factor +++ /dev/null @@ -1,16 +0,0 @@ -USING: help.markup help.syntax kernel math sequences ; -IN: math.bitfields.lib - -HELP: bits -{ $values { "m" integer } { "n" integer } { "m'" integer } } -{ $description "Keep only n bits from the integer m." } -{ $example "USING: math.bitfields.lib prettyprint ;" "HEX: 123abcdef 16 bits .h" "cdef" } ; - -HELP: bitroll -{ $values { "x" "an integer (input)" } { "s" "an integer (shift)" } { "w" "an integer (wrap)" } { "y" integer } } -{ $description "Roll n by s bits to the left, wrapping around after w bits." } -{ $examples - { $example "USING: math.bitfields.lib prettyprint ;" "1 -1 32 bitroll .b" "10000000000000000000000000000000" } - { $example "USING: math.bitfields.lib prettyprint ;" "HEX: ffff0000 8 32 bitroll .h" "ff0000ff" } -} ; - diff --git a/extra/math/bitfields/lib/lib-tests.factor b/extra/math/bitfields/lib/lib-tests.factor deleted file mode 100644 index c002240e69..0000000000 --- a/extra/math/bitfields/lib/lib-tests.factor +++ /dev/null @@ -1,14 +0,0 @@ -USING: math.bitfields.lib tools.test ; -IN: math.bitfields.lib.test - -[ 0 ] [ 1 0 0 bitroll ] unit-test -[ 1 ] [ 1 0 1 bitroll ] unit-test -[ 1 ] [ 1 1 1 bitroll ] unit-test -[ 1 ] [ 1 0 2 bitroll ] unit-test -[ 1 ] [ 1 0 1 bitroll ] unit-test -[ 1 ] [ 1 20 2 bitroll ] unit-test -[ 1 ] [ 1 8 8 bitroll ] unit-test -[ 1 ] [ 1 -8 8 bitroll ] unit-test -[ 1 ] [ 1 -32 8 bitroll ] unit-test -[ 128 ] [ 1 -1 8 bitroll ] unit-test -[ 8 ] [ 1 3 32 bitroll ] unit-test diff --git a/extra/math/bitfields/lib/lib.factor b/extra/math/bitfields/lib/lib.factor deleted file mode 100644 index 1e755d71d9..0000000000 --- a/extra/math/bitfields/lib/lib.factor +++ /dev/null @@ -1,30 +0,0 @@ -USING: hints kernel math ; -IN: math.bitfields.lib - -: clear-bit ( x n -- y ) 2^ bitnot bitand ; inline -: set-bit ( x n -- y ) 2^ bitor ; inline -: bit-clear? ( x n -- ? ) 2^ bitand zero? ; inline -: unmask ( x n -- ? ) bitnot bitand ; inline -: unmask? ( x n -- ? ) unmask 0 > ; inline -: mask ( x n -- ? ) bitand ; inline -: mask? ( x n -- ? ) mask 0 > ; inline -: wrap ( m n -- m' ) 1- bitand ; inline -: bits ( m n -- m' ) 2^ wrap ; inline -: mask-bit ( m n -- m' ) 1- 2^ mask ; inline - -: shift-mod ( n s w -- n ) - >r shift r> 2^ wrap ; inline - -: bitroll ( x s w -- y ) - [ wrap ] keep - [ shift-mod ] - [ [ - ] keep shift-mod ] 3bi bitor ; inline - -: bitroll-32 ( n s -- n' ) 32 bitroll ; - -HINTS: bitroll-32 bignum fixnum ; - -: bitroll-64 ( n s -- n' ) 64 bitroll ; - -HINTS: bitroll-64 bignum fixnum ; - diff --git a/extra/namespaces/lib/lib-tests.factor b/extra/namespaces/lib/lib-tests.factor index 0bc2e6311a..d3f5a12faa 100755 --- a/extra/namespaces/lib/lib-tests.factor +++ b/extra/namespaces/lib/lib-tests.factor @@ -1,8 +1 @@ -IN: namespaces.lib.tests -USING: namespaces.lib kernel tools.test ; -[ ] [ [ ] { } nmake ] unit-test - -[ { 1 } { 2 } ] [ [ 1 0, 2 1, ] { { } { } } nmake ] unit-test - -[ [ ] [ call ] curry { { } } nmake ] must-infer diff --git a/extra/namespaces/lib/lib.factor b/extra/namespaces/lib/lib.factor index da9fde9d79..ae0887e45a 100755 --- a/extra/namespaces/lib/lib.factor +++ b/extra/namespaces/lib/lib.factor @@ -16,45 +16,6 @@ IN: namespaces.lib : set* ( val var -- ) namestack* set-assoc-stack ; -SYMBOL: building-seq -: get-building-seq ( n -- seq ) - building-seq get nth ; - -: n, ( obj n -- ) get-building-seq push ; -: n% ( seq n -- ) get-building-seq push-all ; -: n# ( num n -- ) >r number>string r> n% ; - -: 0, ( obj -- ) 0 n, ; -: 0% ( seq -- ) 0 n% ; -: 0# ( num -- ) 0 n# ; -: 1, ( obj -- ) 1 n, ; -: 1% ( seq -- ) 1 n% ; -: 1# ( num -- ) 1 n# ; -: 2, ( obj -- ) 2 n, ; -: 2% ( seq -- ) 2 n% ; -: 2# ( num -- ) 2 n# ; -: 3, ( obj -- ) 3 n, ; -: 3% ( seq -- ) 3 n% ; -: 3# ( num -- ) 3 n# ; -: 4, ( obj -- ) 4 n, ; -: 4% ( seq -- ) 4 n% ; -: 4# ( num -- ) 4 n# ; - -MACRO: finish-nmake ( exemplars -- ) - length [ firstn ] curry ; - -:: nmake ( quot exemplars -- ) - [ - exemplars - [ 0 swap new-resizable ] map - building-seq set - - quot call - - building-seq get - exemplars [ [ like ] 2map ] [ finish-nmake ] bi - ] with-scope ; inline - : make-object ( quot class -- object ) new [ swap bind ] keep ; inline diff --git a/extra/opengl/capabilities/authors.txt b/extra/opengl/capabilities/authors.txt new file mode 100644 index 0000000000..6a0dc7293a --- /dev/null +++ b/extra/opengl/capabilities/authors.txt @@ -0,0 +1 @@ +Joe Groff \ No newline at end of file diff --git a/extra/opengl/capabilities/capabilities-docs.factor b/extra/opengl/capabilities/capabilities-docs.factor new file mode 100644 index 0000000000..f5424e19da --- /dev/null +++ b/extra/opengl/capabilities/capabilities-docs.factor @@ -0,0 +1,59 @@ +USING: help.markup help.syntax io kernel math quotations +opengl.gl multiline assocs ; +IN: opengl.capabilities + +HELP: gl-version +{ $values { "version" "The version string from the OpenGL implementation" } } +{ $description "Wrapper for " { $snippet "GL_VERSION glGetString" } " that removes the vendor-specific information from the version string." } ; + +HELP: gl-vendor-version +{ $values { "version" "The vendor-specific version information from the OpenGL implementation" } } +{ $description "Wrapper for " { $snippet "GL_VERSION glGetString" } " that returns only the vendor-specific information from the version string." } ; + +HELP: has-gl-version? +{ $values { "version" "A version string" } { "?" "A boolean value" } } +{ $description "Compares the version string returned by " { $link gl-version } " to " { $snippet "version" } ". Returns true if the implementation version meets or exceeds " { $snippet "version" } "." } ; + +HELP: require-gl-version +{ $values { "version" "A version string" } } +{ $description "Throws an exception if " { $link has-gl-version? } " returns false for " { $snippet "version" } "." } ; + +HELP: glsl-version +{ $values { "version" "The GLSL version string from the OpenGL implementation" } } +{ $description "Wrapper for " { $snippet "GL_SHADING_LANGUAGE_VERSION glGetString" } " that removes the vendor-specific information from the version string." } ; + +HELP: glsl-vendor-version +{ $values { "version" "The vendor-specific GLSL version information from the OpenGL implementation" } } +{ $description "Wrapper for " { $snippet "GL_SHADING_LANGUAGE_VERSION glGetString" } " that returns only the vendor-specific information from the version string." } ; + +HELP: has-glsl-version? +{ $values { "version" "A version string" } { "?" "A boolean value" } } +{ $description "Compares the version string returned by " { $link glsl-version } " to " { $snippet "version" } ". Returns true if the implementation version meets or exceeds " { $snippet "version" } "." } ; + +HELP: require-glsl-version +{ $values { "version" "A version string" } } +{ $description "Throws an exception if " { $link has-glsl-version? } " returns false for " { $snippet "version" } "." } ; + +HELP: gl-extensions +{ $values { "seq" "A sequence of strings naming the implementation-supported OpenGL extensions" } } +{ $description "Wrapper for " { $snippet "GL_EXTENSIONS glGetString" } " that returns a sequence of extension names supported by the OpenGL implementation." } ; + +HELP: has-gl-extensions? +{ $values { "extensions" "A sequence of extension name strings" } { "?" "A boolean value" } } +{ $description "Returns true if the set of " { $snippet "extensions" } " is a subset of the implementation-supported extensions returned by " { $link gl-extensions } "." } ; + +HELP: has-gl-version-or-extensions? +{ $values { "version" "A version string" } { "extensions" "A sequence of extension name strings" } { "?" "a boolean" } } +{ $description "Returns true if either " { $link has-gl-version? } " or " { $link has-gl-extensions? } " returns true for " { $snippet "version" } " or " { $snippet "extensions" } ", respectively. Intended for use when required OpenGL functionality can be verified either by a minimum version or a set of equivalent extensions." } ; + +HELP: require-gl-extensions +{ $values { "extensions" "A sequence of extension name strings" } } +{ $description "Throws an exception if " { $link has-gl-extensions? } " returns false for " { $snippet "extensions" } "." } ; + +HELP: require-gl-version-or-extensions +{ $values { "version" "A version string" } { "extensions" "A sequence of extension name strings" } } +{ $description "Throws an exception if neither " { $link has-gl-version? } " nor " { $link has-gl-extensions? } " returns true for " { $snippet "version" } " or " { $snippet "extensions" } ", respectively. Intended for use when required OpenGL functionality can be verified either by a minimum version or a set of equivalent extensions." } ; + +{ require-gl-version require-glsl-version require-gl-extensions require-gl-version-or-extensions has-gl-version? has-glsl-version? has-gl-extensions? has-gl-version-or-extensions? gl-version glsl-version gl-extensions } related-words + +ABOUT: "gl-utilities" diff --git a/extra/opengl/capabilities/capabilities.factor b/extra/opengl/capabilities/capabilities.factor new file mode 100755 index 0000000000..806935d5c9 --- /dev/null +++ b/extra/opengl/capabilities/capabilities.factor @@ -0,0 +1,67 @@ +! Copyright (C) 2008 Joe Groff. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel namespaces sequences splitting opengl.gl +continuations math.parser math arrays sets math.order ; +IN: opengl.capabilities + +: (require-gl) ( thing require-quot make-error-quot -- ) + -rot dupd call + [ 2drop ] + [ swap " " make throw ] + if ; inline + +: gl-extensions ( -- seq ) + GL_EXTENSIONS glGetString " " split ; +: has-gl-extensions? ( extensions -- ? ) + gl-extensions swap [ over member? ] all? nip ; +: (make-gl-extensions-error) ( required-extensions -- ) + gl-extensions diff + "Required OpenGL extensions not supported:\n" % + [ " " % % "\n" % ] each ; +: require-gl-extensions ( extensions -- ) + [ has-gl-extensions? ] + [ (make-gl-extensions-error) ] + (require-gl) ; + +: version-seq ( version-string -- version-seq ) + "." split [ string>number ] map ; + +: version-before? ( version1 version2 -- ? ) + swap version-seq swap version-seq before=? ; + +: (gl-version) ( -- version vendor ) + GL_VERSION glGetString " " split1 ; +: gl-version ( -- version ) + (gl-version) drop ; +: gl-vendor-version ( -- version ) + (gl-version) nip ; +: has-gl-version? ( version -- ? ) + gl-version version-before? ; +: (make-gl-version-error) ( required-version -- ) + "Required OpenGL version " % % " not supported (" % gl-version % " available)" % ; +: require-gl-version ( version -- ) + [ has-gl-version? ] + [ (make-gl-version-error) ] + (require-gl) ; + +: (glsl-version) ( -- version vendor ) + GL_SHADING_LANGUAGE_VERSION glGetString " " split1 ; +: glsl-version ( -- version ) + (glsl-version) drop ; +: glsl-vendor-version ( -- version ) + (glsl-version) nip ; +: has-glsl-version? ( version -- ? ) + glsl-version version-before? ; +: require-glsl-version ( version -- ) + [ has-glsl-version? ] + [ "Required GLSL version " % % " not supported (" % glsl-version % " available)" % ] + (require-gl) ; + +: has-gl-version-or-extensions? ( version extensions -- ? ) + has-gl-extensions? swap has-gl-version? or ; + +: require-gl-version-or-extensions ( version extensions -- ) + 2array [ first2 has-gl-version-or-extensions? ] [ + dup first (make-gl-version-error) "\n" % + second (make-gl-extensions-error) "\n" % + ] (require-gl) ; diff --git a/extra/opengl/capabilities/summary.txt b/extra/opengl/capabilities/summary.txt new file mode 100644 index 0000000000..d31b63b8d4 --- /dev/null +++ b/extra/opengl/capabilities/summary.txt @@ -0,0 +1 @@ +Testing for OpenGL versions and extensions \ No newline at end of file diff --git a/extra/opengl/capabilities/tags.txt b/extra/opengl/capabilities/tags.txt new file mode 100644 index 0000000000..77282be3a9 --- /dev/null +++ b/extra/opengl/capabilities/tags.txt @@ -0,0 +1,2 @@ +opengl +bindings diff --git a/extra/opengl/demo-support/authors.txt b/extra/opengl/demo-support/authors.txt new file mode 100644 index 0000000000..6a0dc7293a --- /dev/null +++ b/extra/opengl/demo-support/authors.txt @@ -0,0 +1 @@ +Joe Groff \ No newline at end of file diff --git a/extra/opengl/demo-support/demo-support.factor b/extra/opengl/demo-support/demo-support.factor new file mode 100755 index 0000000000..2bf2abae95 --- /dev/null +++ b/extra/opengl/demo-support/demo-support.factor @@ -0,0 +1,89 @@ +USING: arrays kernel math math.functions +math.order math.vectors namespaces opengl opengl.gl sequences ui +ui.gadgets ui.gestures ui.render accessors ; +IN: opengl.demo-support + +: FOV 2.0 sqrt 1+ ; inline +: MOUSE-MOTION-SCALE 0.5 ; inline +: KEY-ROTATE-STEP 1.0 ; inline + +SYMBOL: last-drag-loc + +TUPLE: demo-gadget < gadget yaw pitch distance ; + +: new-demo-gadget ( yaw pitch distance class -- gadget ) + new-gadget + swap >>distance + swap >>pitch + swap >>yaw ; + +GENERIC: far-plane ( gadget -- z ) +GENERIC: near-plane ( gadget -- z ) +GENERIC: distance-step ( gadget -- dz ) + +M: demo-gadget far-plane ( gadget -- z ) + drop 4.0 ; +M: demo-gadget near-plane ( gadget -- z ) + drop 1.0 64.0 / ; +M: demo-gadget distance-step ( gadget -- dz ) + drop 1.0 64.0 / ; + +: fov-ratio ( gadget -- fov ) dim>> dup first2 min v/n ; + +: yaw-demo-gadget ( yaw gadget -- ) + [ + ] with change-yaw relayout-1 ; + +: pitch-demo-gadget ( pitch gadget -- ) + [ + ] with change-pitch relayout-1 ; + +: zoom-demo-gadget ( distance gadget -- ) + [ + ] with change-distance relayout-1 ; + +M: demo-gadget pref-dim* ( gadget -- dim ) + drop { 640 480 } ; + +: -+ ( x -- -x x ) + [ neg ] keep ; + +: demo-gadget-frustum ( gadget -- -x x -y y near far ) + [ near-plane ] [ far-plane ] [ fov-ratio ] tri [ + nip swap FOV / v*n + first2 [ -+ ] bi@ + ] 3keep drop ; + +: demo-gadget-set-matrices ( gadget -- ) + GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT bitor glClear + [ + GL_PROJECTION glMatrixMode + glLoadIdentity + demo-gadget-frustum glFrustum + ] [ + GL_MODELVIEW glMatrixMode + glLoadIdentity + [ >r 0.0 0.0 r> distance>> neg glTranslatef ] + [ pitch>> 1.0 0.0 0.0 glRotatef ] + [ yaw>> 0.0 1.0 0.0 glRotatef ] + tri + ] bi ; + +: reset-last-drag-rel ( -- ) + { 0 0 } last-drag-loc set-global ; +: last-drag-rel ( -- rel ) + drag-loc [ last-drag-loc get v- ] keep last-drag-loc set-global ; + +: drag-yaw-pitch ( -- yaw pitch ) + last-drag-rel MOUSE-MOTION-SCALE v*n first2 ; + +demo-gadget H{ + { T{ key-down f f "LEFT" } [ KEY-ROTATE-STEP neg swap yaw-demo-gadget ] } + { T{ key-down f f "RIGHT" } [ KEY-ROTATE-STEP swap yaw-demo-gadget ] } + { T{ key-down f f "DOWN" } [ KEY-ROTATE-STEP neg swap pitch-demo-gadget ] } + { T{ key-down f f "UP" } [ KEY-ROTATE-STEP swap pitch-demo-gadget ] } + { T{ key-down f f "=" } [ dup distance-step neg swap zoom-demo-gadget ] } + { T{ key-down f f "-" } [ dup distance-step swap zoom-demo-gadget ] } + + { T{ button-down f f 1 } [ drop reset-last-drag-rel ] } + { T{ drag f 1 } [ drag-yaw-pitch rot [ pitch-demo-gadget ] keep yaw-demo-gadget ] } + { T{ mouse-scroll } [ scroll-direction get second over distance-step * swap zoom-demo-gadget ] } +} set-gestures + diff --git a/extra/opengl/demo-support/summary.txt b/extra/opengl/demo-support/summary.txt new file mode 100644 index 0000000000..eca681450f --- /dev/null +++ b/extra/opengl/demo-support/summary.txt @@ -0,0 +1 @@ +Common support for OpenGL demos \ No newline at end of file diff --git a/extra/opengl/demo-support/tags.txt b/extra/opengl/demo-support/tags.txt new file mode 100644 index 0000000000..a6797bf627 --- /dev/null +++ b/extra/opengl/demo-support/tags.txt @@ -0,0 +1 @@ +opengl diff --git a/extra/opengl/framebuffers/authors.txt b/extra/opengl/framebuffers/authors.txt new file mode 100644 index 0000000000..6a0dc7293a --- /dev/null +++ b/extra/opengl/framebuffers/authors.txt @@ -0,0 +1 @@ +Joe Groff \ No newline at end of file diff --git a/extra/opengl/framebuffers/framebuffers-docs.factor b/extra/opengl/framebuffers/framebuffers-docs.factor new file mode 100644 index 0000000000..c5507dcce1 --- /dev/null +++ b/extra/opengl/framebuffers/framebuffers-docs.factor @@ -0,0 +1,35 @@ +USING: help.markup help.syntax io kernel math quotations +opengl.gl multiline assocs ; +IN: opengl.framebuffers + +HELP: gen-framebuffer +{ $values { "id" integer } } +{ $description "Wrapper for " { $link glGenFramebuffersEXT } " to handle the common case of generating a single framebuffer ID." } ; + +HELP: gen-renderbuffer +{ $values { "id" integer } } +{ $description "Wrapper for " { $link glGenRenderbuffersEXT } " to handle the common case of generating a single render buffer ID." } ; + +HELP: delete-framebuffer +{ $values { "id" integer } } +{ $description "Wrapper for " { $link glDeleteFramebuffersEXT } " to handle the common case of deleting a single framebuffer ID." } ; + +HELP: delete-renderbuffer +{ $values { "id" integer } } +{ $description "Wrapper for " { $link glDeleteRenderbuffersEXT } " to handle the common case of deleting a single render buffer ID." } ; + +{ gen-framebuffer delete-framebuffer } related-words +{ gen-renderbuffer delete-renderbuffer } related-words + +HELP: framebuffer-incomplete? +{ $values { "status/f" "The framebuffer error code, or " { $snippet "f" } " if the framebuffer is render-complete." } } +{ $description "Checks the framebuffer currently bound by " { $link glBindFramebufferEXT } " or " { $link with-framebuffer } " to see if it is incomplete, i.e., it is not ready to be rendered to." } ; + +HELP: check-framebuffer +{ $description "Checks the framebuffer currently bound by " { $link glBindFramebufferEXT } " or " { $link with-framebuffer } " with " { $link framebuffer-incomplete? } ", and throws a descriptive error if the framebuffer is incomplete." } ; + +HELP: with-framebuffer +{ $values { "id" "The id of a framebuffer object." } { "quot" "a quotation" } } +{ $description "Binds framebuffer " { $snippet "id" } " in the dynamic extent of " { $snippet "quot" } ", restoring the window framebuffer when finished." } ; + +ABOUT: "gl-utilities" \ No newline at end of file diff --git a/extra/opengl/framebuffers/framebuffers.factor b/extra/opengl/framebuffers/framebuffers.factor new file mode 100644 index 0000000000..346789e1c5 --- /dev/null +++ b/extra/opengl/framebuffers/framebuffers.factor @@ -0,0 +1,43 @@ +! Copyright (C) 2008 Joe Groff. +! See http://factorcode.org/license.txt for BSD license. +USING: opengl opengl.gl combinators continuations kernel +alien.c-types ; +IN: opengl.framebuffers + +: gen-framebuffer ( -- id ) + [ glGenFramebuffersEXT ] (gen-gl-object) ; +: gen-renderbuffer ( -- id ) + [ glGenRenderbuffersEXT ] (gen-gl-object) ; + +: delete-framebuffer ( id -- ) + [ glDeleteFramebuffersEXT ] (delete-gl-object) ; +: delete-renderbuffer ( id -- ) + [ glDeleteRenderbuffersEXT ] (delete-gl-object) ; + +: framebuffer-incomplete? ( -- status/f ) + GL_FRAMEBUFFER_EXT glCheckFramebufferStatusEXT + dup GL_FRAMEBUFFER_COMPLETE_EXT = f rot ? ; + +: framebuffer-error ( status -- * ) + { + { GL_FRAMEBUFFER_COMPLETE_EXT [ "framebuffer complete" ] } + { GL_FRAMEBUFFER_UNSUPPORTED_EXT [ "framebuffer configuration unsupported" ] } + { GL_FRAMEBUFFER_INCOMPLETE_ATTACHMENT_EXT [ "framebuffer incomplete (incomplete attachment)" ] } + { GL_FRAMEBUFFER_INCOMPLETE_MISSING_ATTACHMENT_EXT [ "framebuffer incomplete (missing attachment)" ] } + { GL_FRAMEBUFFER_INCOMPLETE_DIMENSIONS_EXT [ "framebuffer incomplete (dimension mismatch)" ] } + { GL_FRAMEBUFFER_INCOMPLETE_FORMATS_EXT [ "framebuffer incomplete (format mismatch)" ] } + { GL_FRAMEBUFFER_INCOMPLETE_DRAW_BUFFER_EXT [ "framebuffer incomplete (draw buffer(s) have no attachment)" ] } + { GL_FRAMEBUFFER_INCOMPLETE_READ_BUFFER_EXT [ "framebuffer incomplete (read buffer has no attachment)" ] } + [ drop gl-error "unknown framebuffer error" ] + } case throw ; + +: check-framebuffer ( -- ) + framebuffer-incomplete? [ framebuffer-error ] when* ; + +: with-framebuffer ( id quot -- ) + GL_FRAMEBUFFER_EXT rot glBindFramebufferEXT + [ GL_FRAMEBUFFER_EXT 0 glBindFramebufferEXT ] [ ] cleanup ; inline + +: framebuffer-attachment ( attachment -- id ) + GL_FRAMEBUFFER_EXT swap GL_FRAMEBUFFER_ATTACHMENT_OBJECT_NAME_EXT + 0 [ glGetFramebufferAttachmentParameterivEXT ] keep *uint ; diff --git a/extra/opengl/framebuffers/summary.txt b/extra/opengl/framebuffers/summary.txt new file mode 100644 index 0000000000..3ef713ac13 --- /dev/null +++ b/extra/opengl/framebuffers/summary.txt @@ -0,0 +1 @@ +Rendering to offscreen textures using the GL_EXT_framebuffer_object extension \ No newline at end of file diff --git a/extra/opengl/framebuffers/tags.txt b/extra/opengl/framebuffers/tags.txt new file mode 100644 index 0000000000..77282be3a9 --- /dev/null +++ b/extra/opengl/framebuffers/tags.txt @@ -0,0 +1,2 @@ +opengl +bindings diff --git a/extra/opengl/gadgets/gadgets-tests.factor b/extra/opengl/gadgets/gadgets-tests.factor new file mode 100644 index 0000000000..499ec9730a --- /dev/null +++ b/extra/opengl/gadgets/gadgets-tests.factor @@ -0,0 +1,4 @@ +IN: opengl.gadgets.tests +USING: tools.test opengl.gadgets ; + +\ render* must-infer diff --git a/extra/opengl/gadgets/gadgets.factor b/extra/opengl/gadgets/gadgets.factor new file mode 100644 index 0000000000..9e670c04ab --- /dev/null +++ b/extra/opengl/gadgets/gadgets.factor @@ -0,0 +1,112 @@ +! Copyright (C) 2008 Matthew Willis. +! See http://factorcode.org/license.txt for BSD license. +USING: locals math.functions math namespaces +opengl.gl accessors kernel opengl ui.gadgets +fry assocs +destructors sequences ui.render colors ; +IN: opengl.gadgets + +TUPLE: texture-gadget ; + +GENERIC: render* ( gadget -- texture dims ) +GENERIC: cache-key* ( gadget -- key ) + +M: texture-gadget cache-key* ; + +SYMBOL: textures +SYMBOL: refcounts + +: init-cache ( symbol -- ) + dup get [ drop ] [ H{ } clone swap set-global ] if ; + +textures init-cache +refcounts init-cache + +: refcount-change ( gadget quot -- ) + >r cache-key* refcounts get + [ [ 0 ] unless* ] r> compose change-at ; + +TUPLE: cache-entry tex dims ; +C: cache-entry + +: make-entry ( gadget -- entry ) + dup render* + [ swap cache-key* textures get set-at ] keep ; + +: get-entry ( gadget -- {texture,dims} ) + dup cache-key* textures get at + [ nip ] [ make-entry ] if* ; + +: get-dims ( gadget -- dims ) + get-entry dims>> ; + +: get-texture ( gadget -- texture ) + get-entry tex>> ; + +: release-texture ( gadget -- ) + cache-key* textures get delete-at* + [ tex>> delete-texture ] [ drop ] if ; + +M: texture-gadget graft* ( gadget -- ) [ 1+ ] refcount-change ; + +M: texture-gadget ungraft* ( gadget -- ) + dup [ 1- ] refcount-change + dup cache-key* refcounts get at + zero? [ release-texture ] [ drop ] if ; + +: 2^-ceil ( x -- y ) + dup 2 < [ 2 * ] [ 1- log2 1+ 2^ ] if ; foldable flushable + +: 2^-bounds ( dim -- dim' ) + [ 2^-ceil ] map ; foldable flushable + +:: (render-bytes) ( dims bytes format texture -- ) + GL_ENABLE_BIT [ + GL_TEXTURE_2D glEnable + GL_TEXTURE_2D texture glBindTexture + GL_TEXTURE_2D + 0 + GL_RGBA + dims 2^-bounds first2 + 0 + format + GL_UNSIGNED_BYTE + bytes + glTexImage2D + init-texture + GL_TEXTURE_2D 0 glBindTexture + ] do-attribs ; + +: render-bytes ( dims bytes format -- texture ) + gen-texture [ (render-bytes) ] keep ; + +: render-bytes* ( dims bytes format -- texture dims ) + pick >r render-bytes r> ; + +:: four-corners ( dim -- ) + [let* | w [ dim first ] + h [ dim second ] + dim' [ dim dup 2^-bounds [ /f ] 2map ] + w' [ dim' first ] + h' [ dim' second ] | + 0 0 glTexCoord2d 0 0 glVertex2d + 0 h' glTexCoord2d 0 h glVertex2d + w' h' glTexCoord2d w h glVertex2d + w' 0 glTexCoord2d w 0 glVertex2d + ] ; + +M: texture-gadget draw-gadget* ( gadget -- ) + origin get [ + GL_ENABLE_BIT [ + white gl-color + 1.0 -1.0 glPixelZoom + GL_TEXTURE_2D glEnable + GL_TEXTURE_2D over get-texture glBindTexture + GL_QUADS [ + get-dims four-corners + ] do-state + GL_TEXTURE_2D 0 glBindTexture + ] do-attribs + ] with-translation ; + +M: texture-gadget pref-dim* ( gadget -- dim ) get-dims ; diff --git a/extra/opengl/shaders/authors.txt b/extra/opengl/shaders/authors.txt new file mode 100644 index 0000000000..6a0dc7293a --- /dev/null +++ b/extra/opengl/shaders/authors.txt @@ -0,0 +1 @@ +Joe Groff \ No newline at end of file diff --git a/extra/opengl/shaders/shaders-docs.factor b/extra/opengl/shaders/shaders-docs.factor new file mode 100644 index 0000000000..1a10071ddf --- /dev/null +++ b/extra/opengl/shaders/shaders-docs.factor @@ -0,0 +1,101 @@ +USING: help.markup help.syntax io kernel math quotations +opengl.gl multiline assocs strings ; +IN: opengl.shaders + +HELP: gl-shader +{ $class-description { $snippet "gl-shader" } " is a predicate class comprising values returned by OpenGL to represent shader objects. The following words are provided for creating and manipulating these objects:" + { $list + { { $link } " - Compile GLSL code into a shader object" } + { { $link gl-shader-ok? } " - Check whether a shader object compiled successfully" } + { { $link check-gl-shader } " - Throw an error unless a shader object compiled successfully" } + { { $link gl-shader-info-log } " - Retrieve the info log of messages generated by the GLSL compiler" } + { { $link delete-gl-shader } " - Invalidate a shader object" } + } + "The derived predicate classes " { $link vertex-shader } " and " { $link fragment-shader } " are also defined for the two standard kinds of shader defined by the OpenGL specification." } ; + +HELP: vertex-shader +{ $class-description { $snippet "vertex-shader" } " is the predicate class of " { $link gl-shader } " objects that refer to shaders of type " { $snippet "GL_VERTEX_SHADER" } ". In addition to the " { $snippet "gl-shader" } " words, the following vertex shader-specific functions are defined:" + { $list + { { $link } " - Compile GLSL code into a vertex shader object "} + } +} ; + +HELP: fragment-shader +{ $class-description { $snippet "fragment-shader" } " is the predicate class of " { $link gl-shader } " objects that refer to shaders of type " { $snippet "GL_FRAGMENT_SHADER" } ". In addition to the " { $snippet "gl-shader" } " words, the following fragment shader-specific functions are defined:" + { $list + { { $link } " - Compile GLSL code into a fragment shader object "} + } +} ; + +HELP: +{ $values { "source" "The GLSL source code to compile" } { "kind" "The kind of shader to compile, such as " { $snippet "GL_VERTEX_SHADER" } " or " { $snippet "GL_FRAGMENT_SHADER" } } { "shader" "a new " { $link gl-shader } } } +{ $description "Tries to compile the given GLSL source into a shader object. The returned object can be checked for validity by " { $link check-gl-shader } " or " { $link gl-shader-ok? } ". Errors and warnings generated by the GLSL compiler will be collected in the info log, available from " { $link gl-shader-info-log } ".\n\nWhen the shader object is no longer needed, it should be deleted using " { $link delete-gl-shader } " or else be attached to a " { $link gl-program } " object deleted using " { $link delete-gl-program } "." } ; + +HELP: +{ $values { "source" "The GLSL source code to compile" } { "vertex-shader" "a new " { $link vertex-shader } } } +{ $description "Tries to compile the given GLSL source into a vertex shader object. Equivalent to " { $snippet "GL_VERTEX_SHADER " } "." } ; + +HELP: +{ $values { "source" "The GLSL source code to compile" } { "fragment-shader" "a new " { $link fragment-shader } } } +{ $description "Tries to compile the given GLSL source into a fragment shader object. Equivalent to " { $snippet "GL_FRAGMENT_SHADER " } "." } ; + +HELP: gl-shader-ok? +{ $values { "shader" "A " { $link gl-shader } " object" } { "?" "a boolean" } } +{ $description "Returns a boolean value indicating whether the given shader object compiled successfully. Compilation errors and warnings are available in the shader's info log, which can be gotten using " { $link gl-shader-info-log } "." } ; + +HELP: check-gl-shader +{ $values { "shader" "A " { $link gl-shader } " object" } } +{ $description "Throws an error containing the " { $link gl-shader-info-log } " for the shader object if it failed to compile. Otherwise, the shader object is left on the stack." } ; + +HELP: delete-gl-shader +{ $values { "shader" "A " { $link gl-shader } " object" } } +{ $description "Deletes the shader object, invalidating it and releasing any resources allocated for it by the OpenGL implementation." } ; + +HELP: gl-shader-info-log +{ $values { "shader" "A " { $link gl-shader } " object" } { "shader" "a new " { $link gl-shader } } { "log" string } } +{ $description "Retrieves the info log for " { $snippet "shader" } ", including any errors or warnings generated in compiling the shader object." } ; + +HELP: gl-program +{ $class-description { $snippet "gl-program" } " is a predicate class comprising values returned by OpenGL to represent proram objects. The following words are provided for creating and manipulating these objects:" + { $list + { { $link } ", " { $link } " - Link a set of shaders into a GLSL program" } + { { $link gl-program-ok? } " - Check whether a program object linked successfully" } + { { $link check-gl-program } " - Throw an error unless a program object linked successfully" } + { { $link gl-program-info-log } " - Retrieve the info log of messages generated by the GLSL linker" } + { { $link gl-program-shaders } " - Retrieve the set of shader objects composing the GLSL program" } + { { $link delete-gl-program } " - Invalidate a program object and all its attached shaders" } + { { $link with-gl-program } " - Use a program object" } + } +} ; + +HELP: +{ $values { "shaders" "A sequence of " { $link gl-shader } " objects." } { "program" "a new " { $link gl-program } } } +{ $description "Creates a new GLSL program object, attaches all the shader objects in the " { $snippet "shaders" } " sequence, and attempts to link them. The returned object can be checked for validity by " { $link check-gl-program } " or " { $link gl-program-ok? } ". Errors and warnings generated by the GLSL linker will be collected in the info log, available from " { $link gl-program-info-log } ".\n\nWhen the program object and its attached shaders are no longer needed, it should be deleted using " { $link delete-gl-program } "." } ; + +HELP: +{ $values { "vertex-shader-source" "A string containing GLSL vertex shader source" } { "fragment-shader-source" "A string containing GLSL fragment shader source" } { "program" "a new " { $link gl-program } } } +{ $description "Wrapper for " { $link } " for the simple case of compiling a single vertex shader and fragment shader and linking them into a GLSL program. Throws an exception if compiling or linking fails." } ; + +{ } related-words + +HELP: gl-program-ok? +{ $values { "program" "A " { $link gl-program } " object" } { "?" "a boolean" } } +{ $description "Returns a boolean value indicating whether the given program object linked successfully. Link errors and warnings are available in the program's info log, which can be gotten using " { $link gl-program-info-log } "." } ; + +HELP: check-gl-program +{ $values { "program" "A " { $link gl-program } " object" } } +{ $description "Throws an error containing the " { $link gl-program-info-log } " for the program object if it failed to link. Otherwise, the program object is left on the stack." } ; + +HELP: gl-program-info-log +{ $values { "program" "A " { $link gl-program } " object" } { "log" string } } +{ $description "Retrieves the info log for " { $snippet "program" } ", including any errors or warnings generated in linking the program object." } ; + +HELP: delete-gl-program +{ $values { "program" "A " { $link gl-program } " object" } } +{ $description "Deletes the program object, invalidating it and releasing any resources allocated for it by the OpenGL implementation. Any attached " { $link gl-shader } "s are also deleted.\n\nIf the shader objects should be preserved, they should each be detached using " { $link detach-gl-program-shader } ". The program object can then be destroyed alone using " { $link delete-gl-program-only } "." } ; + +HELP: with-gl-program +{ $values { "program" "A " { $link gl-program } " object" } { "quot" "A quotation with stack effect " { $snippet "( program -- )" } } } +{ $description "Enables " { $snippet "program" } " for all OpenGL calls made in the dynamic extent of " { $snippet "quot" } ". " { $snippet "program" } " is left on the top of the stack when " { $snippet "quot" } " is called. The fixed-function pipeline is restored at the end of " { $snippet "quot" } "." } ; + +ABOUT: "gl-utilities" diff --git a/extra/opengl/shaders/shaders.factor b/extra/opengl/shaders/shaders.factor new file mode 100755 index 0000000000..d52e55417f --- /dev/null +++ b/extra/opengl/shaders/shaders.factor @@ -0,0 +1,119 @@ +! Copyright (C) 2008 Joe Groff. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel opengl.gl alien.c-types continuations namespaces +assocs alien alien.strings libc opengl math sequences combinators +combinators.lib macros arrays io.encodings.ascii fry ; +IN: opengl.shaders + +: with-gl-shader-source-ptr ( string quot -- ) + swap ascii malloc-string [ swap call ] keep free ; inline + +: ( source kind -- shader ) + glCreateShader dup rot + [ 1 swap f glShaderSource ] with-gl-shader-source-ptr + [ glCompileShader ] keep + gl-error ; + +: (gl-shader?) ( object -- ? ) + dup integer? [ glIsShader c-bool> ] [ drop f ] if ; + +: gl-shader-get-int ( shader enum -- value ) + 0 [ glGetShaderiv ] keep *int ; + +: gl-shader-ok? ( shader -- ? ) + GL_COMPILE_STATUS gl-shader-get-int c-bool> ; + +: ( source -- vertex-shader ) + GL_VERTEX_SHADER ; inline + +: (vertex-shader?) ( object -- ? ) + dup (gl-shader?) + [ GL_SHADER_TYPE gl-shader-get-int GL_VERTEX_SHADER = ] + [ drop f ] if ; + +: ( source -- fragment-shader ) + GL_FRAGMENT_SHADER ; inline + +: (fragment-shader?) ( object -- ? ) + dup (gl-shader?) + [ GL_SHADER_TYPE gl-shader-get-int GL_FRAGMENT_SHADER = ] + [ drop f ] if ; + +: gl-shader-info-log-length ( shader -- log-length ) + GL_INFO_LOG_LENGTH gl-shader-get-int ; inline + +: gl-shader-info-log ( shader -- log ) + dup gl-shader-info-log-length dup [ + [ 0 swap glGetShaderInfoLog ] keep + ascii alien>string + ] with-malloc ; + +: check-gl-shader ( shader -- shader ) + dup gl-shader-ok? [ dup gl-shader-info-log throw ] unless ; + +: delete-gl-shader ( shader -- ) glDeleteShader ; inline + +PREDICATE: gl-shader < integer (gl-shader?) ; +PREDICATE: vertex-shader < gl-shader (vertex-shader?) ; +PREDICATE: fragment-shader < gl-shader (fragment-shader?) ; + +! Programs + +: ( shaders -- program ) + glCreateProgram swap + [ dupd glAttachShader ] each + [ glLinkProgram ] keep + gl-error ; + +: (gl-program?) ( object -- ? ) + dup integer? [ glIsProgram c-bool> ] [ drop f ] if ; + +: gl-program-get-int ( program enum -- value ) + 0 [ glGetProgramiv ] keep *int ; + +: gl-program-ok? ( program -- ? ) + GL_LINK_STATUS gl-program-get-int c-bool> ; + +: gl-program-info-log-length ( program -- log-length ) + GL_INFO_LOG_LENGTH gl-program-get-int ; inline + +: gl-program-info-log ( program -- log ) + dup gl-program-info-log-length dup [ + [ 0 swap glGetProgramInfoLog ] keep + ascii alien>string + ] with-malloc ; + +: check-gl-program ( program -- program ) + dup gl-program-ok? [ dup gl-program-info-log throw ] unless ; + +: gl-program-shaders-length ( program -- shaders-length ) + GL_ATTACHED_SHADERS gl-program-get-int ; inline + +: gl-program-shaders ( program -- shaders ) + dup gl-program-shaders-length + dup "GLuint" + 0 swap + [ glGetAttachedShaders ] { 3 1 } multikeep + c-uint-array> ; + +: delete-gl-program-only ( program -- ) + glDeleteProgram ; inline + +: detach-gl-program-shader ( program shader -- ) + glDetachShader ; inline + +: delete-gl-program ( program -- ) + dup gl-program-shaders [ + 2dup detach-gl-program-shader delete-gl-shader + ] each delete-gl-program-only ; + +: with-gl-program ( program quot -- ) + over glUseProgram [ 0 glUseProgram ] [ ] cleanup ; inline + +PREDICATE: gl-program < integer (gl-program?) ; + +: ( vertex-shader-source fragment-shader-source -- program ) + >r check-gl-shader + r> check-gl-shader + 2array check-gl-program ; + diff --git a/extra/opengl/shaders/summary.txt b/extra/opengl/shaders/summary.txt new file mode 100644 index 0000000000..c55f76668f --- /dev/null +++ b/extra/opengl/shaders/summary.txt @@ -0,0 +1 @@ +OpenGL Shading Language (GLSL) support \ No newline at end of file diff --git a/extra/opengl/shaders/tags.txt b/extra/opengl/shaders/tags.txt new file mode 100644 index 0000000000..ce0345edc9 --- /dev/null +++ b/extra/opengl/shaders/tags.txt @@ -0,0 +1,3 @@ +opengl +glsl +bindings \ No newline at end of file diff --git a/extra/pack/pack.factor b/extra/pack/pack.factor index ed2756bb80..adceab72f6 100755 --- a/extra/pack/pack.factor +++ b/extra/pack/pack.factor @@ -1,7 +1,7 @@ USING: alien alien.c-types arrays assocs byte-arrays io io.binary io.streams.string kernel math math.parser namespaces parser prettyprint quotations sequences strings vectors words -macros math.functions math.bitfields.lib ; +macros math.functions math.bitwise ; IN: pack SYMBOL: big-endian diff --git a/extra/peg/search/authors.txt b/extra/peg/search/authors.txt deleted file mode 100644 index 44b06f94bc..0000000000 --- a/extra/peg/search/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Chris Double diff --git a/extra/peg/search/search-docs.factor b/extra/peg/search/search-docs.factor deleted file mode 100755 index 565601ea11..0000000000 --- a/extra/peg/search/search-docs.factor +++ /dev/null @@ -1,44 +0,0 @@ -! Copyright (C) 2006 Chris Double. -! See http://factorcode.org/license.txt for BSD license. -USING: help.syntax help.markup peg ; -IN: peg.search - -HELP: tree-write -{ $values - { "object" "an object" } } -{ $description - "Write the object to the standard output stream, unless " - "it is an array, in which case recurse through the array " - "writing each object to the stream." } -{ $example "USE: peg.search" "{ 65 \"bc\" { 68 \"ef\" } } tree-write" "AbcDef" } ; - -HELP: search -{ $values - { "string" "a string" } - { "parser" "a peg based parser" } - { "seq" "a sequence" } -} -{ $description - "Returns a sequence containing the parse results of all substrings " - "from the input string that successfully parse using the " - "parser." -} - -{ $example "USING: peg.parsers peg.search prettyprint ;" "\"one 123 two 456\" 'integer' search ." "V{ 123 456 }" } -{ $example "USING: peg peg.parsers peg.search prettyprint ;" "\"one 123 \\\"hello\\\" two 456\" 'integer' 'string' 2choice search ." "V{ 123 \"hello\" 456 }" } -{ $see-also replace } ; - -HELP: replace -{ $values - { "string" "a string" } - { "parser" "a peg based parser" } - { "result" "a string" } -} -{ $description - "Returns a copy of the original string but with all substrings that " - "successfully parse with the given parser replaced with " - "the result of that parser." -} -{ $example "USING: math math.parser peg peg.parsers peg.search prettyprint ;" "\"one 123 two 456\" 'integer' [ 2 * number>string ] action replace ." "\"one 246 two 912\"" } -{ $see-also search } ; - diff --git a/extra/peg/search/search-tests.factor b/extra/peg/search/search-tests.factor deleted file mode 100755 index b22a5ef0d0..0000000000 --- a/extra/peg/search/search-tests.factor +++ /dev/null @@ -1,19 +0,0 @@ -! Copyright (C) 2007 Chris Double. -! See http://factorcode.org/license.txt for BSD license. -! -USING: kernel math math.parser arrays tools.test peg peg.parsers -peg.search ; -IN: peg.search.tests - -{ V{ 123 456 } } [ - "abc 123 def 456" 'integer' search -] unit-test - -{ V{ 123 "hello" 456 } } [ - "one 123 \"hello\" two 456" 'integer' 'string' 2array choice search -] unit-test - -{ "abc 246 def 912" } [ - "abc 123 def 456" 'integer' [ 2 * number>string ] action replace -] unit-test - diff --git a/extra/peg/search/search.factor b/extra/peg/search/search.factor deleted file mode 100755 index 04e4affe39..0000000000 --- a/extra/peg/search/search.factor +++ /dev/null @@ -1,29 +0,0 @@ -! Copyright (C) 2006 Chris Double. -! See http://factorcode.org/license.txt for BSD license. -USING: kernel math io io.streams.string sequences strings -combinators peg memoize arrays continuations ; -IN: peg.search - -: tree-write ( object -- ) - { - { [ dup number? ] [ write1 ] } - { [ dup string? ] [ write ] } - { [ dup sequence? ] [ [ tree-write ] each ] } - { [ t ] [ write ] } - } cond ; - -MEMO: any-char-parser ( -- parser ) - [ drop t ] satisfy ; - -: search ( string parser -- seq ) - any-char-parser [ drop f ] action 2array choice repeat0 - [ parse sift ] [ 3drop { } ] recover ; - - -: (replace) ( string parser -- seq ) - any-char-parser 2array choice repeat0 parse sift ; - -: replace ( string parser -- result ) - [ (replace) [ tree-write ] each ] with-string-writer ; - - diff --git a/extra/peg/search/summary.txt b/extra/peg/search/summary.txt deleted file mode 100644 index ad27ade319..0000000000 --- a/extra/peg/search/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Search and replace using parsing expression grammars diff --git a/extra/peg/search/tags.txt b/extra/peg/search/tags.txt deleted file mode 100644 index 9da56880c0..0000000000 --- a/extra/peg/search/tags.txt +++ /dev/null @@ -1 +0,0 @@ -parsing diff --git a/extra/sequences/lib/lib-tests.factor b/extra/sequences/lib/lib-tests.factor index 3744a7217a..76f3bb4f5b 100755 --- a/extra/sequences/lib/lib-tests.factor +++ b/extra/sequences/lib/lib-tests.factor @@ -43,9 +43,6 @@ IN: sequences.lib.tests [ { { 1 1 1 1 } { 2 2 } { 3 } { 4 } { 5 } { 6 6 6 } } ] [ { 1 1 1 1 2 2 3 4 5 6 6 6 } [ = ] monotonic-split [ >array ] map ] unit-test -[ 2 ] [ V{ 10 20 30 } [ delete-random drop ] keep length ] unit-test -[ V{ } [ delete-random drop ] keep length ] must-fail - [ { 1 9 25 } ] [ { 1 3 5 6 } [ sq ] [ even? ] map-until ] unit-test [ { 2 4 } ] [ { 2 4 1 3 } [ even? ] take-while ] unit-test @@ -69,6 +66,3 @@ IN: sequences.lib.tests [ "empty" ] [ { } [ "not empty" ] [ "empty" ] if-seq ] unit-test [ { 1 } "not empty" ] [ { 1 } [ "not empty" ] [ "empty" ] if-seq ] unit-test - -[ "empty" ] [ { } [ "empty" ] [ "not empty" ] if-empty ] unit-test -[ { 1 } "not empty" ] [ { 1 } [ "empty" ] [ "not empty" ] if-empty ] unit-test diff --git a/extra/sequences/lib/lib.factor b/extra/sequences/lib/lib.factor index 9e984857f6..a09b3d5b82 100755 --- a/extra/sequences/lib/lib.factor +++ b/extra/sequences/lib/lib.factor @@ -88,9 +88,6 @@ IN: sequences.lib : monotonic-split ( seq quot -- newseq ) over empty? [ 2drop { } ] [ (monotonic-split) ] if ; -: delete-random ( seq -- value ) - [ length random ] keep [ nth ] 2keep delete-nth ; - ERROR: element-not-found ; : split-around ( seq quot -- before elem after ) dupd find over [ element-not-found ] unless @@ -202,12 +199,6 @@ PRIVATE> : ?nth* ( n seq -- elt/f ? ) 2dup bounds-check? [ nth-unsafe t ] [ 2drop f f ] if ; flushable -: remove-nth ( n seq -- seq' ) - [ swap head-slice ] [ swap 1+ tail-slice ] 2bi append ; - -: insert-nth ( elt n seq -- seq' ) - swap cut-slice [ swap 1array ] dip 3append ; - : if-seq ( seq quot1 quot2 -- ) [ f like ] 2dip if* ; inline : if-empty ( seq quot1 quot2 -- ) swap if-seq ; inline diff --git a/extra/serial/serial.factor b/extra/serial/serial.factor index 39a63927da..df304e0f04 100644 --- a/extra/serial/serial.factor +++ b/extra/serial/serial.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: accessors alien.c-types assocs combinators destructors -kernel math math.bitfields math.parser sequences summary system +kernel math math.bitwise math.parser sequences summary system vocabs.loader ; IN: serial diff --git a/extra/serial/unix/bsd/bsd.factor b/extra/serial/unix/bsd/bsd.factor index feed85348b..d31d947dcb 100644 --- a/extra/serial/unix/bsd/bsd.factor +++ b/extra/serial/unix/bsd/bsd.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.syntax kernel math.bitfields sequences system serial ; +USING: alien.syntax kernel math.bitwise sequences system serial ; IN: serial.unix M: bsd lookup-baud ( m -- n ) diff --git a/extra/serial/unix/unix-tests.factor b/extra/serial/unix/unix-tests.factor index bab6c3f4f1..e9126a5961 100644 --- a/extra/serial/unix/unix-tests.factor +++ b/extra/serial/unix/unix-tests.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors kernel math.bitfields serial serial.unix ; +USING: accessors kernel math.bitwise serial serial.unix ; IN: serial.unix : serial-obj ( -- obj ) diff --git a/extra/serial/unix/unix.factor b/extra/serial/unix/unix.factor index 7ed5bced37..90dbd185bd 100644 --- a/extra/serial/unix/unix.factor +++ b/extra/serial/unix/unix.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: accessors alien.c-types alien.syntax combinators io.ports -io.streams.duplex io.unix.backend system kernel math math.bitfields +io.streams.duplex io.unix.backend system kernel math math.bitwise vocabs.loader unix serial serial.unix.termios ; IN: serial.unix diff --git a/extra/ui/gadgets/cartesian/cartesian.factor b/extra/ui/gadgets/cartesian/cartesian.factor new file mode 100644 index 0000000000..730b0f5b44 --- /dev/null +++ b/extra/ui/gadgets/cartesian/cartesian.factor @@ -0,0 +1,42 @@ + +USING: kernel combinators sequences opengl.gl + ui.render ui.gadgets ui.gadgets.slate + accessors ; + +IN: ui.gadgets.cartesian + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +TUPLE: cartesian < slate x-min x-max y-min y-max z-min z-max perspective ; + +: init-cartesian ( cartesian -- cartesian ) + init-slate + -10 >>x-min + 10 >>x-max + -10 >>y-min + 10 >>y-max + -1 >>z-min + 1 >>z-max ; + +: ( -- cartesian ) cartesian new init-cartesian ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +M: cartesian establish-coordinate-system ( cartesian -- cartesian ) + dup + { + [ x-min>> ] [ x-max>> ] + [ y-min>> ] [ y-max>> ] + [ z-min>> ] [ z-max>> ] + } + cleave + glOrtho ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: x-range ( cartesian range -- cartesian ) first2 [ >>x-min ] [ >>x-max ] bi* ; +: y-range ( cartesian range -- cartesian ) first2 [ >>y-min ] [ >>y-max ] bi* ; +: z-range ( cartesian range -- cartesian ) first2 [ >>z-min ] [ >>z-max ] bi* ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + diff --git a/extra/ui/gadgets/frame-buffer/frame-buffer.factor b/extra/ui/gadgets/frame-buffer/frame-buffer.factor new file mode 100644 index 0000000000..2d58037982 --- /dev/null +++ b/extra/ui/gadgets/frame-buffer/frame-buffer.factor @@ -0,0 +1,115 @@ + +USING: kernel alien.c-types combinators sequences splitting grouping + opengl.gl ui.gadgets ui.render + math math.vectors accessors math.geometry.rect ; + +IN: ui.gadgets.frame-buffer + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +TUPLE: frame-buffer < gadget action pdim last-dim graft ungraft pixels ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: init-frame-buffer-pixels ( frame-buffer -- frame-buffer ) + dup + rect-dim product "uint[4]" + >>pixels ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: new-frame-buffer ( class -- gadget ) + new-gadget + [ ] >>action + { 100 100 } >>pdim + [ ] >>graft + [ ] >>ungraft ; + +: ( -- frame-buffer ) frame-buffer new-frame-buffer ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: draw-pixels ( fb -- fb ) + dup >r + dup >r + rect-dim first2 GL_RGBA GL_UNSIGNED_INT r> pixels>> glDrawPixels + r> ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: read-pixels ( fb -- fb ) + dup >r + dup >r + >r + 0 0 r> rect-dim first2 GL_RGBA GL_UNSIGNED_INT r> pixels>> glReadPixels + r> ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +M: frame-buffer pref-dim* pdim>> ; +M: frame-buffer graft* graft>> call ; +M: frame-buffer ungraft* ungraft>> call ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: copy-row ( old new -- ) + 2dup min-length swap >r head-slice 0 r> copy ; + +! : copy-pixels ( old-pixels old-width new-pixels new-width -- ) +! [ group ] 2bi@ +! [ copy-row ] 2each ; + +! : copy-pixels ( old-pixels old-width new-pixels new-width -- ) +! [ 16 * group ] 2bi@ +! [ copy-row ] 2each ; + +: copy-pixels ( old-pixels old-width new-pixels new-width -- ) + [ 16 * ] 2bi@ + [ copy-row ] 2each ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +M: frame-buffer layout* ( fb -- ) + { + { + [ dup last-dim>> f = ] + [ + init-frame-buffer-pixels + dup + rect-dim >>last-dim + drop + ] + } + { + [ dup [ rect-dim ] [ last-dim>> ] bi = not ] + [ + dup [ pixels>> ] [ last-dim>> first ] bi + + rot init-frame-buffer-pixels + dup rect-dim >>last-dim + + [ pixels>> ] [ rect-dim first ] bi + + copy-pixels + ] + } + { [ t ] [ drop ] } + } + cond ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +M: frame-buffer draw-gadget* ( fb -- ) + + dup rect-dim { 0 1 } v* first2 glRasterPos2i + + draw-pixels + + dup action>> call + + glFlush + + read-pixels + + drop ; + diff --git a/extra/ui/gadgets/handler/authors.txt b/extra/ui/gadgets/handler/authors.txt new file mode 100755 index 0000000000..6cfd5da273 --- /dev/null +++ b/extra/ui/gadgets/handler/authors.txt @@ -0,0 +1 @@ +Eduardo Cavazos diff --git a/extra/ui/gadgets/handler/handler.factor b/extra/ui/gadgets/handler/handler.factor new file mode 100644 index 0000000000..1c12142593 --- /dev/null +++ b/extra/ui/gadgets/handler/handler.factor @@ -0,0 +1,11 @@ + +USING: kernel assocs ui.gestures ui.gadgets.wrappers accessors ; + +IN: ui.gadgets.handler + +TUPLE: handler < wrapper table ; + +: ( child -- handler ) handler new-wrapper ; + +M: handler handle-gesture ( gesture gadget -- ? ) + tuck table>> at dup [ call f ] [ 2drop t ] if ; \ No newline at end of file diff --git a/extra/ui/gadgets/plot/plot.factor b/extra/ui/gadgets/plot/plot.factor new file mode 100644 index 0000000000..52cd2faed7 --- /dev/null +++ b/extra/ui/gadgets/plot/plot.factor @@ -0,0 +1,137 @@ + +USING: kernel quotations arrays sequences math math.ranges fry + opengl opengl.gl ui.render ui.gadgets.cartesian processing.shapes + accessors ; + +IN: ui.gadgets.plot + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +TUPLE: plot < cartesian functions points ; + +: init-plot ( plot -- plot ) + init-cartesian + { } >>functions + 100 >>points ; + +: ( -- plot ) plot new init-plot ; + +: step-size ( plot -- step-size ) + [ [ x-max>> ] [ x-min>> ] bi - ] [ points>> ] bi / ; + +: plot-range ( plot -- range ) + [ x-min>> ] [ x-max>> ] [ step-size ] tri ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +TUPLE: function function color ; + +GENERIC: plot-function ( plot object -- plot ) + +M: callable plot-function ( plot quotation -- plot ) + >r dup plot-range r> '[ dup @ 2array ] map line-strip ; + +M: function plot-function ( plot function -- plot ) + dup color>> dup [ >stroke-color ] [ drop ] if + >r dup plot-range r> function>> '[ dup @ 2array ] map line-strip ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: plot-functions ( plot -- plot ) dup functions>> [ plot-function ] each ; + +: draw-axis ( plot -- plot ) + dup + [ [ x-min>> ] [ drop 0 ] bi 2array ] + [ [ x-max>> ] [ drop 0 ] bi 2array ] bi line* + dup + [ [ drop 0 ] [ y-min>> ] bi 2array ] + [ [ drop 0 ] [ y-max>> ] bi 2array ] bi line* ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +USING: ui.gadgets.slate ; + +M: plot draw-slate ( plot -- plot ) + 2 glLineWidth + draw-axis + plot-functions + fill-mode + 1 glLineWidth ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: add-function ( plot function -- plot ) + over functions>> swap suffix >>functions ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: x-span ( plot -- span ) [ x-max>> ] [ x-min>> ] bi - ; +: y-span ( plot -- span ) [ y-max>> ] [ y-min>> ] bi - ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +USING: ui.gestures ui.gadgets ; + +: left ( plot -- plot ) + dup [ x-min>> ] [ x-span 1/10 * ] bi - >>x-min + dup [ x-max>> ] [ x-span 1/10 * ] bi - >>x-max + dup relayout-1 ; + +: right ( plot -- plot ) + dup [ x-min>> ] [ x-span 1/10 * ] bi + >>x-min + dup [ x-max>> ] [ x-span 1/10 * ] bi + >>x-max + dup relayout-1 ; + +: down ( plot -- plot ) + dup [ y-min>> ] [ y-span 1/10 * ] bi - >>y-min + dup [ y-max>> ] [ y-span 1/10 * ] bi - >>y-max + dup relayout-1 ; + +: up ( plot -- plot ) + dup [ y-min>> ] [ y-span 1/10 * ] bi + >>y-min + dup [ y-max>> ] [ y-span 1/10 * ] bi + >>y-max + dup relayout-1 ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: zoom-in-horizontal ( plot -- plot ) + dup [ x-min>> ] [ x-span 1/10 * ] bi + >>x-min + dup [ x-max>> ] [ x-span 1/10 * ] bi - >>x-max ; + +: zoom-in-vertical ( plot -- plot ) + dup [ y-min>> ] [ y-span 1/10 * ] bi + >>y-min + dup [ y-max>> ] [ y-span 1/10 * ] bi - >>y-max ; + +: zoom-in ( plot -- plot ) + zoom-in-horizontal + zoom-in-vertical + dup relayout-1 ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: zoom-out-horizontal ( plot -- plot ) + dup [ x-min>> ] [ x-span 1/10 * ] bi - >>x-min + dup [ x-max>> ] [ x-span 1/10 * ] bi + >>x-max ; + +: zoom-out-vertical ( plot -- plot ) + dup [ y-min>> ] [ y-span 1/10 * ] bi - >>y-min + dup [ y-max>> ] [ y-span 1/10 * ] bi + >>y-max ; + +: zoom-out ( plot -- plot ) + zoom-out-horizontal + zoom-out-vertical + dup relayout-1 ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +plot + H{ + { T{ mouse-enter } [ request-focus ] } + { T{ key-down f f "LEFT" } [ left drop ] } + { T{ key-down f f "RIGHT" } [ right drop ] } + { T{ key-down f f "DOWN" } [ down drop ] } + { T{ key-down f f "UP" } [ up drop ] } + { T{ key-down f f "a" } [ zoom-in drop ] } + { T{ key-down f f "z" } [ zoom-out drop ] } + } +set-gestures \ No newline at end of file diff --git a/extra/ui/gadgets/slate/authors.txt b/extra/ui/gadgets/slate/authors.txt new file mode 100755 index 0000000000..6cfd5da273 --- /dev/null +++ b/extra/ui/gadgets/slate/authors.txt @@ -0,0 +1 @@ +Eduardo Cavazos diff --git a/extra/ui/gadgets/slate/slate.factor b/extra/ui/gadgets/slate/slate.factor new file mode 100644 index 0000000000..0505586b53 --- /dev/null +++ b/extra/ui/gadgets/slate/slate.factor @@ -0,0 +1,116 @@ + +USING: kernel namespaces opengl ui.render ui.gadgets accessors ; + +IN: ui.gadgets.slate + +TUPLE: slate < gadget action pdim graft ungraft ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: init-slate ( slate -- slate ) + init-gadget + [ ] >>action + { 200 200 } >>pdim + [ ] >>graft + [ ] >>ungraft ; + +: ( action -- slate ) + slate new + init-slate + swap >>action ; + +M: slate pref-dim* ( slate -- dim ) pdim>> ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +USING: combinators arrays sequences math math.geometry + opengl.gl ui.gadgets.worlds ; + +: screen-y* ( gadget -- loc ) + { + [ find-world height ] + [ screen-loc second ] + [ height ] + } + cleave + + - ; + +: screen-loc* ( gadget -- loc ) + { + [ screen-loc first ] + [ screen-y* ] + } + cleave + 2array ; + +: setup-viewport ( gadget -- gadget ) + dup + { + [ screen-loc* ] + [ dim>> ] + } + cleave + gl-viewport ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: default-coordinate-system ( gadget -- gadget ) + dup + { + [ drop 0 ] + [ width 1 - ] + [ height 1 - ] + [ drop 0 ] + } + cleave + -1 1 + glOrtho ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +M: slate graft* ( slate -- ) graft>> call ; +M: slate ungraft* ( slate -- ) ungraft>> call ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +GENERIC: establish-coordinate-system ( gadget -- gadget ) + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +M: slate establish-coordinate-system ( slate -- slate ) + default-coordinate-system ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +GENERIC: draw-slate ( slate -- slate ) + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +M: slate draw-slate ( slate -- slate ) dup action>> call ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +M: slate draw-gadget* ( slate -- ) + + GL_PROJECTION glMatrixMode glPushMatrix glLoadIdentity + + establish-coordinate-system + + GL_MODELVIEW glMatrixMode glPushMatrix glLoadIdentity + + setup-viewport + + draw-slate + + GL_PROJECTION glMatrixMode glPopMatrix glLoadIdentity + GL_MODELVIEW glMatrixMode glPopMatrix glLoadIdentity + + dup + find-world + ! The world coordinate system is a little wacky: + dup { [ drop 0 ] [ width ] [ height ] [ drop 0 ] } cleave -1 1 glOrtho + setup-viewport + drop + drop ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/extra/ui/gadgets/tabs/authors.txt b/extra/ui/gadgets/tabs/authors.txt new file mode 100755 index 0000000000..50c9c38812 --- /dev/null +++ b/extra/ui/gadgets/tabs/authors.txt @@ -0,0 +1 @@ +William Schlieper \ No newline at end of file diff --git a/extra/ui/gadgets/tabs/summary.txt b/extra/ui/gadgets/tabs/summary.txt new file mode 100755 index 0000000000..a55610bcc0 --- /dev/null +++ b/extra/ui/gadgets/tabs/summary.txt @@ -0,0 +1 @@ +Tabbed windows \ No newline at end of file diff --git a/extra/ui/gadgets/tabs/tabs.factor b/extra/ui/gadgets/tabs/tabs.factor new file mode 100755 index 0000000000..50e2df2e9e --- /dev/null +++ b/extra/ui/gadgets/tabs/tabs.factor @@ -0,0 +1,62 @@ +! Copyright (C) 2008 William Schlieper +! See http://factorcode.org/license.txt for BSD license. + +USING: accessors kernel fry math math.vectors sequences arrays vectors assocs + hashtables models models.range models.compose combinators + ui ui.gadgets ui.gadgets.buttons ui.gadgets.frames ui.gadgets.packs + ui.gadgets.grids ui.gadgets.viewports ui.gadgets.books locals ; + +IN: ui.gadgets.tabs + +TUPLE: tabbed < frame names toggler content ; + +DEFER: (del-page) + +:: add-toggle ( model n name toggler -- ) + + n name toggler parent>> '[ , , , (del-page) ] "X" swap + @right grid-add + n model name @center grid-add + toggler swap add-gadget drop ; + +: redo-toggler ( tabbed -- ) + [ names>> ] [ model>> ] [ toggler>> ] tri + [ clear-gadget ] keep + [ [ length ] keep ] 2dip + '[ , _ _ , add-toggle ] 2each ; + +: refresh-book ( tabbed -- ) + model>> [ ] change-model ; + +: (del-page) ( n name tabbed -- ) + { [ [ remove ] change-names redo-toggler ] + [ dupd [ names>> length ] [ model>> ] bi + [ [ = ] keep swap [ 1- ] when + [ < ] keep swap [ 1- ] when ] change-model ] + [ content>> nth-gadget unparent ] + [ refresh-book ] + } cleave ; + +: add-page ( page name tabbed -- ) + [ names>> push ] 2keep + [ [ model>> swap ] + [ names>> length 1 - swap ] + [ toggler>> ] tri add-toggle ] + [ content>> swap add-gadget drop ] + [ refresh-book ] tri ; + +: del-page ( name tabbed -- ) + [ names>> index ] 2keep (del-page) ; + +: new-tabbed ( assoc class -- tabbed ) + new-frame + 0 >>model + 1 >>fill >>toggler + dup toggler>> @left grid-add + swap + [ keys >vector >>names ] + [ values over model>> >>content dup content>> @center grid-add ] + bi + dup redo-toggler ; + +: ( assoc -- tabbed ) tabbed new-tabbed ; diff --git a/extra/ui/gadgets/tiling/tiling.factor b/extra/ui/gadgets/tiling/tiling.factor new file mode 100644 index 0000000000..2d096966af --- /dev/null +++ b/extra/ui/gadgets/tiling/tiling.factor @@ -0,0 +1,153 @@ + +USING: kernel sequences math math.order + ui.gadgets ui.gadgets.tracks ui.gestures + fry accessors ; + +IN: ui.gadgets.tiling + +TUPLE: tiling < track gadgets tiles first focused ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: init-tiling ( tiling -- tiling ) + init-track + { 1 0 } >>orientation + V{ } clone >>gadgets + 2 >>tiles + 0 >>first + 0 >>focused ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: ( -- gadget ) tiling new init-tiling ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: bounded-subseq ( seq a b -- seq ) + [ 0 max ] dip + pick length [ min ] curry bi@ + rot + subseq ; + +: tiling-gadgets-to-map ( tiling -- gadgets ) + [ gadgets>> ] + [ first>> ] + [ [ first>> ] [ tiles>> ] bi + ] + tri + bounded-subseq ; + +: tiling-map-gadgets ( tiling -- tiling ) + dup clear-track + dup tiling-gadgets-to-map [ 1 track-add ] each ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: tiling-add ( tiling gadget -- tiling ) + over gadgets>> push + tiling-map-gadgets ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: first-gadget ( tiling -- index ) drop 0 ; + +: last-gadget ( tiling -- index ) gadgets>> length 1 - ; + +: first-viewable ( tiling -- index ) first>> ; + +: last-viewable ( tiling -- index ) [ first>> ] [ tiles>> ] bi + 1 - ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: make-focused-mapped ( tiling -- tiling ) + + dup [ focused>> ] [ first>> ] bi < + [ dup first>> 1 - >>first ] + [ ] + if + + dup [ last-viewable ] [ focused>> ] bi < + [ dup first>> 1 + >>first ] + [ ] + if ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: check-focused-bounds ( tiling -- tiling ) + dup focused>> 0 max over gadgets>> length 1 - min >>focused ; + +: focus-prev ( tiling -- tiling ) + dup focused>> 1 - >>focused + check-focused-bounds + make-focused-mapped + tiling-map-gadgets + dup request-focus ; + +: focus-next ( tiling -- tiling ) + dup focused>> 1 + >>focused + check-focused-bounds + make-focused-mapped + tiling-map-gadgets + dup request-focus ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: exchanged! ( seq a b -- ) + [ 0 max ] bi@ + pick length 1 - '[ , min ] bi@ + rot exchange ; + +: move-prev ( tiling -- tiling ) + dup [ gadgets>> ] [ focused>> 1 - ] [ focused>> ] tri exchanged! + focus-prev ; + +: move-next ( tiling -- tiling ) + dup [ gadgets>> ] [ focused>> ] [ focused>> 1 + ] tri exchanged! + focus-next ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: add-tile ( tiling -- tiling ) + dup tiles>> 1 + >>tiles + tiling-map-gadgets ; + +: del-tile ( tiling -- tiling ) + dup tiles>> 1 - 1 max >>tiles + tiling-map-gadgets ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +M: tiling focusable-child* ( tiling -- child/t ) + [ focused>> ] [ gadgets>> ] bi nth ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +TUPLE: tiling-shelf < tiling ; +TUPLE: tiling-pile < tiling ; + +: ( -- gadget ) + tiling-shelf new init-tiling { 1 0 } >>orientation ; + +: ( -- gadget ) + tiling-pile new init-tiling { 0 1 } >>orientation ; + +tiling-shelf + H{ + { T{ key-down f { A+ } "LEFT" } [ focus-prev drop ] } + { T{ key-down f { A+ } "RIGHT" } [ focus-next drop ] } + { T{ key-down f { S+ A+ } "LEFT" } [ move-prev drop ] } + { T{ key-down f { S+ A+ } "RIGHT" } [ move-next drop ] } + { T{ key-down f { C+ } "[" } [ del-tile drop ] } + { T{ key-down f { C+ } "]" } [ add-tile drop ] } + } +set-gestures + +tiling-pile + H{ + { T{ key-down f { A+ } "UP" } [ focus-prev drop ] } + { T{ key-down f { A+ } "DOWN" } [ focus-next drop ] } + { T{ key-down f { S+ A+ } "UP" } [ move-prev drop ] } + { T{ key-down f { S+ A+ } "DOWN" } [ move-next drop ] } + { T{ key-down f { C+ } "[" } [ del-tile drop ] } + { T{ key-down f { C+ } "]" } [ add-tile drop ] } + } +set-gestures diff --git a/extra/units/authors.txt b/extra/units/authors.txt new file mode 100755 index 0000000000..7c1b2f2279 --- /dev/null +++ b/extra/units/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/extra/units/constants/authors.txt b/extra/units/constants/authors.txt new file mode 100755 index 0000000000..7c1b2f2279 --- /dev/null +++ b/extra/units/constants/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/extra/units/constants/constants.factor b/extra/units/constants/constants.factor new file mode 100644 index 0000000000..7350cbf03d --- /dev/null +++ b/extra/units/constants/constants.factor @@ -0,0 +1,15 @@ +! USING: kernel math si-units ; +IN: units.constants + +! From: http://physics.nist.gov/constants + +! speed of light in vacuum +! : c 299792458 m/s ; +! : c0 299792458 m/s ; ! same as c +! : c-vacuum 299792458 m/s ; ! same as c +! +! ! more to come +! +! : avogadro +! 6.02214179e23 { } { mol } ; + diff --git a/extra/units/constants/constants.txt b/extra/units/constants/constants.txt new file mode 100644 index 0000000000..8adc40301d --- /dev/null +++ b/extra/units/constants/constants.txt @@ -0,0 +1,336 @@ + + Fundamental Physical Constants --- Complete Listing + + + From: http://physics.nist.gov/constants + + + + Quantity Value Uncertainty Unit +------------------------------------------------------------------------------------------------------------------------ +{220} lattice spacing of silicon 192.015 5762 e-12 0.000 0050 e-12 m +alpha particle-electron mass ratio 7294.299 5365 0.000 0031 +alpha particle mass 6.644 656 20 e-27 0.000 000 33 e-27 kg +alpha particle mass energy equivalent 5.971 919 17 e-10 0.000 000 30 e-10 J +alpha particle mass energy equivalent in MeV 3727.379 109 0.000 093 MeV +alpha particle mass in u 4.001 506 179 127 0.000 000 000 062 u +alpha particle molar mass 4.001 506 179 127 e-3 0.000 000 000 062 e-3 kg mol^-1 +alpha particle-proton mass ratio 3.972 599 689 51 0.000 000 000 41 +Angstrom star 1.000 014 98 e-10 0.000 000 90 e-10 m +atomic mass constant 1.660 538 782 e-27 0.000 000 083 e-27 kg +atomic mass constant energy equivalent 1.492 417 830 e-10 0.000 000 074 e-10 J +atomic mass constant energy equivalent in MeV 931.494 028 0.000 023 MeV +atomic mass unit-electron volt relationship 931.494 028 e6 0.000 023 e6 eV +atomic mass unit-hartree relationship 3.423 177 7149 e7 0.000 000 0049 e7 E_h +atomic mass unit-hertz relationship 2.252 342 7369 e23 0.000 000 0032 e23 Hz +atomic mass unit-inverse meter relationship 7.513 006 671 e14 0.000 000 011 e14 m^-1 +atomic mass unit-joule relationship 1.492 417 830 e-10 0.000 000 074 e-10 J +atomic mass unit-kelvin relationship 1.080 9527 e13 0.000 0019 e13 K +atomic mass unit-kilogram relationship 1.660 538 782 e-27 0.000 000 083 e-27 kg +atomic unit of 1st hyperpolarizablity 3.206 361 533 e-53 0.000 000 081 e-53 C^3 m^3 J^-2 +atomic unit of 2nd hyperpolarizablity 6.235 380 95 e-65 0.000 000 31 e-65 C^4 m^4 J^-3 +atomic unit of action 1.054 571 628 e-34 0.000 000 053 e-34 J s +atomic unit of charge 1.602 176 487 e-19 0.000 000 040 e-19 C +atomic unit of charge density 1.081 202 300 e12 0.000 000 027 e12 C m^-3 +atomic unit of current 6.623 617 63 e-3 0.000 000 17 e-3 A +atomic unit of electric dipole mom. 8.478 352 81 e-30 0.000 000 21 e-30 C m +atomic unit of electric field 5.142 206 32 e11 0.000 000 13 e11 V m^-1 +atomic unit of electric field gradient 9.717 361 66 e21 0.000 000 24 e21 V m^-2 +atomic unit of electric polarizablity 1.648 777 2536 e-41 0.000 000 0034 e-41 C^2 m^2 J^-1 +atomic unit of electric potential 27.211 383 86 0.000 000 68 V +atomic unit of electric quadrupole mom. 4.486 551 07 e-40 0.000 000 11 e-40 C m^2 +atomic unit of energy 4.359 743 94 e-18 0.000 000 22 e-18 J +atomic unit of force 8.238 722 06 e-8 0.000 000 41 e-8 N +atomic unit of length 0.529 177 208 59 e-10 0.000 000 000 36 e-10 m +atomic unit of mag. dipole mom. 1.854 801 830 e-23 0.000 000 046 e-23 J T^-1 +atomic unit of mag. flux density 2.350 517 382 e5 0.000 000 059 e5 T +atomic unit of magnetizability 7.891 036 433 e-29 0.000 000 027 e-29 J T^-2 +atomic unit of mass 9.109 382 15 e-31 0.000 000 45 e-31 kg +atomic unit of momentum 1.992 851 565 e-24 0.000 000 099 e-24 kg m s^-1 +atomic unit of permittivity 1.112 650 056... e-10 (exact) F m^-1 +atomic unit of time 2.418 884 326 505 e-17 0.000 000 000 016 e-17 s +atomic unit of velocity 2.187 691 2541 e6 0.000 000 0015 e6 m s^-1 +Avogadro constant 6.022 141 79 e23 0.000 000 30 e23 mol^-1 +Bohr magneton 927.400 915 e-26 0.000 023 e-26 J T^-1 +Bohr magneton in eV/T 5.788 381 7555 e-5 0.000 000 0079 e-5 eV T^-1 +Bohr magneton in Hz/T 13.996 246 04 e9 0.000 000 35 e9 Hz T^-1 +Bohr magneton in inverse meters per tesla 46.686 4515 0.000 0012 m^-1 T^-1 +Bohr magneton in K/T 0.671 7131 0.000 0012 K T^-1 +Bohr radius 0.529 177 208 59 e-10 0.000 000 000 36 e-10 m +Boltzmann constant 1.380 6504 e-23 0.000 0024 e-23 J K^-1 +Boltzmann constant in eV/K 8.617 343 e-5 0.000 015 e-5 eV K^-1 +Boltzmann constant in Hz/K 2.083 6644 e10 0.000 0036 e10 Hz K^-1 +Boltzmann constant in inverse meters per kelvin 69.503 56 0.000 12 m^-1 K^-1 +characteristic impedance of vacuum 376.730 313 461... (exact) ohm +classical electron radius 2.817 940 2894 e-15 0.000 000 0058 e-15 m +Compton wavelength 2.426 310 2175 e-12 0.000 000 0033 e-12 m +Compton wavelength over 2 pi 386.159 264 59 e-15 0.000 000 53 e-15 m +conductance quantum 7.748 091 7004 e-5 0.000 000 0053 e-5 S +conventional value of Josephson constant 483 597.9 e9 (exact) Hz V^-1 +conventional value of von Klitzing constant 25 812.807 (exact) ohm +Cu x unit 1.002 076 99 e-13 0.000 000 28 e-13 m +deuteron-electron mag. mom. ratio -4.664 345 537 e-4 0.000 000 039 e-4 +deuteron-electron mass ratio 3670.482 9654 0.000 0016 +deuteron g factor 0.857 438 2308 0.000 000 0072 +deuteron mag. mom. 0.433 073 465 e-26 0.000 000 011 e-26 J T^-1 +deuteron mag. mom. to Bohr magneton ratio 0.466 975 4556 e-3 0.000 000 0039 e-3 +deuteron mag. mom. to nuclear magneton ratio 0.857 438 2308 0.000 000 0072 +deuteron mass 3.343 583 20 e-27 0.000 000 17 e-27 kg +deuteron mass energy equivalent 3.005 062 72 e-10 0.000 000 15 e-10 J +deuteron mass energy equivalent in MeV 1875.612 793 0.000 047 MeV +deuteron mass in u 2.013 553 212 724 0.000 000 000 078 u +deuteron molar mass 2.013 553 212 724 e-3 0.000 000 000 078 e-3 kg mol^-1 +deuteron-neutron mag. mom. ratio -0.448 206 52 0.000 000 11 +deuteron-proton mag. mom. ratio 0.307 012 2070 0.000 000 0024 +deuteron-proton mass ratio 1.999 007 501 08 0.000 000 000 22 +deuteron rms charge radius 2.1402 e-15 0.0028 e-15 m +electric constant 8.854 187 817... e-12 (exact) F m^-1 +electron charge to mass quotient -1.758 820 150 e11 0.000 000 044 e11 C kg^-1 +electron-deuteron mag. mom. ratio -2143.923 498 0.000 018 +electron-deuteron mass ratio 2.724 437 1093 e-4 0.000 000 0012 e-4 +electron g factor -2.002 319 304 3622 0.000 000 000 0015 +electron gyromag. ratio 1.760 859 770 e11 0.000 000 044 e11 s^-1 T^-1 +electron gyromag. ratio over 2 pi 28 024.953 64 0.000 70 MHz T^-1 +electron mag. mom. -928.476 377 e-26 0.000 023 e-26 J T^-1 +electron mag. mom. anomaly 1.159 652 181 11 e-3 0.000 000 000 74 e-3 +electron mag. mom. to Bohr magneton ratio -1.001 159 652 181 11 0.000 000 000 000 74 +electron mag. mom. to nuclear magneton ratio -1838.281 970 92 0.000 000 80 +electron mass 9.109 382 15 e-31 0.000 000 45 e-31 kg +electron mass energy equivalent 8.187 104 38 e-14 0.000 000 41 e-14 J +electron mass energy equivalent in MeV 0.510 998 910 0.000 000 013 MeV +electron mass in u 5.485 799 0943 e-4 0.000 000 0023 e-4 u +electron molar mass 5.485 799 0943 e-7 0.000 000 0023 e-7 kg mol^-1 +electron-muon mag. mom. ratio 206.766 9877 0.000 0052 +electron-muon mass ratio 4.836 331 71 e-3 0.000 000 12 e-3 +electron-neutron mag. mom. ratio 960.920 50 0.000 23 +electron-neutron mass ratio 5.438 673 4459 e-4 0.000 000 0033 e-4 +electron-proton mag. mom. ratio -658.210 6848 0.000 0054 +electron-proton mass ratio 5.446 170 2177 e-4 0.000 000 0024 e-4 +electron-tau mass ratio 2.875 64 e-4 0.000 47 e-4 +electron to alpha particle mass ratio 1.370 933 555 70 e-4 0.000 000 000 58 e-4 +electron to shielded helion mag. mom. ratio 864.058 257 0.000 010 +electron to shielded proton mag. mom. ratio -658.227 5971 0.000 0072 +electron volt 1.602 176 487 e-19 0.000 000 040 e-19 J +electron volt-atomic mass unit relationship 1.073 544 188 e-9 0.000 000 027 e-9 u +electron volt-hartree relationship 3.674 932 540 e-2 0.000 000 092 e-2 E_h +electron volt-hertz relationship 2.417 989 454 e14 0.000 000 060 e14 Hz +electron volt-inverse meter relationship 8.065 544 65 e5 0.000 000 20 e5 m^-1 +electron volt-joule relationship 1.602 176 487 e-19 0.000 000 040 e-19 J +electron volt-kelvin relationship 1.160 4505 e4 0.000 0020 e4 K +electron volt-kilogram relationship 1.782 661 758 e-36 0.000 000 044 e-36 kg +elementary charge 1.602 176 487 e-19 0.000 000 040 e-19 C +elementary charge over h 2.417 989 454 e14 0.000 000 060 e14 A J^-1 +Faraday constant 96 485.3399 0.0024 C mol^-1 +Faraday constant for conventional electric current 96 485.3401 0.0048 C_90 mol^-1 +Fermi coupling constant 1.166 37 e-5 0.000 01 e-5 GeV^-2 +fine-structure constant 7.297 352 5376 e-3 0.000 000 0050 e-3 +first radiation constant 3.741 771 18 e-16 0.000 000 19 e-16 W m^2 +first radiation constant for spectral radiance 1.191 042 759 e-16 0.000 000 059 e-16 W m^2 sr^-1 +hartree-atomic mass unit relationship 2.921 262 2986 e-8 0.000 000 0042 e-8 u +hartree-electron volt relationship 27.211 383 86 0.000 000 68 eV +Hartree energy 4.359 743 94 e-18 0.000 000 22 e-18 J +Hartree energy in eV 27.211 383 86 0.000 000 68 eV +hartree-hertz relationship 6.579 683 920 722 e15 0.000 000 000 044 e15 Hz +hartree-inverse meter relationship 2.194 746 313 705 e7 0.000 000 000 015 e7 m^-1 +hartree-joule relationship 4.359 743 94 e-18 0.000 000 22 e-18 J +hartree-kelvin relationship 3.157 7465 e5 0.000 0055 e5 K +hartree-kilogram relationship 4.850 869 34 e-35 0.000 000 24 e-35 kg +helion-electron mass ratio 5495.885 2765 0.000 0052 +helion mass 5.006 411 92 e-27 0.000 000 25 e-27 kg +helion mass energy equivalent 4.499 538 64 e-10 0.000 000 22 e-10 J +helion mass energy equivalent in MeV 2808.391 383 0.000 070 MeV +helion mass in u 3.014 932 2473 0.000 000 0026 u +helion molar mass 3.014 932 2473 e-3 0.000 000 0026 e-3 kg mol^-1 +helion-proton mass ratio 2.993 152 6713 0.000 000 0026 +hertz-atomic mass unit relationship 4.439 821 6294 e-24 0.000 000 0064 e-24 u +hertz-electron volt relationship 4.135 667 33 e-15 0.000 000 10 e-15 eV +hertz-hartree relationship 1.519 829 846 006 e-16 0.000 000 000 010 e-16 E_h +hertz-inverse meter relationship 3.335 640 951... e-9 (exact) m^-1 +hertz-joule relationship 6.626 068 96 e-34 0.000 000 33 e-34 J +hertz-kelvin relationship 4.799 2374 e-11 0.000 0084 e-11 K +hertz-kilogram relationship 7.372 496 00 e-51 0.000 000 37 e-51 kg +inverse fine-structure constant 137.035 999 679 0.000 000 094 +inverse meter-atomic mass unit relationship 1.331 025 0394 e-15 0.000 000 0019 e-15 u +inverse meter-electron volt relationship 1.239 841 875 e-6 0.000 000 031 e-6 eV +inverse meter-hartree relationship 4.556 335 252 760 e-8 0.000 000 000 030 e-8 E_h +inverse meter-hertz relationship 299 792 458 (exact) Hz +inverse meter-joule relationship 1.986 445 501 e-25 0.000 000 099 e-25 J +inverse meter-kelvin relationship 1.438 7752 e-2 0.000 0025 e-2 K +inverse meter-kilogram relationship 2.210 218 70 e-42 0.000 000 11 e-42 kg +inverse of conductance quantum 12 906.403 7787 0.000 0088 ohm +Josephson constant 483 597.891 e9 0.012 e9 Hz V^-1 +joule-atomic mass unit relationship 6.700 536 41 e9 0.000 000 33 e9 u +joule-electron volt relationship 6.241 509 65 e18 0.000 000 16 e18 eV +joule-hartree relationship 2.293 712 69 e17 0.000 000 11 e17 E_h +joule-hertz relationship 1.509 190 450 e33 0.000 000 075 e33 Hz +joule-inverse meter relationship 5.034 117 47 e24 0.000 000 25 e24 m^-1 +joule-kelvin relationship 7.242 963 e22 0.000 013 e22 K +joule-kilogram relationship 1.112 650 056... e-17 (exact) kg +kelvin-atomic mass unit relationship 9.251 098 e-14 0.000 016 e-14 u +kelvin-electron volt relationship 8.617 343 e-5 0.000 015 e-5 eV +kelvin-hartree relationship 3.166 8153 e-6 0.000 0055 e-6 E_h +kelvin-hertz relationship 2.083 6644 e10 0.000 0036 e10 Hz +kelvin-inverse meter relationship 69.503 56 0.000 12 m^-1 +kelvin-joule relationship 1.380 6504 e-23 0.000 0024 e-23 J +kelvin-kilogram relationship 1.536 1807 e-40 0.000 0027 e-40 kg +kilogram-atomic mass unit relationship 6.022 141 79 e26 0.000 000 30 e26 u +kilogram-electron volt relationship 5.609 589 12 e35 0.000 000 14 e35 eV +kilogram-hartree relationship 2.061 486 16 e34 0.000 000 10 e34 E_h +kilogram-hertz relationship 1.356 392 733 e50 0.000 000 068 e50 Hz +kilogram-inverse meter relationship 4.524 439 15 e41 0.000 000 23 e41 m^-1 +kilogram-joule relationship 8.987 551 787... e16 (exact) J +kilogram-kelvin relationship 6.509 651 e39 0.000 011 e39 K +lattice parameter of silicon 543.102 064 e-12 0.000 014 e-12 m +Loschmidt constant (273.15 K, 101.325 kPa) 2.686 7774 e25 0.000 0047 e25 m^-3 +mag. constant 12.566 370 614... e-7 (exact) N A^-2 +mag. flux quantum 2.067 833 667 e-15 0.000 000 052 e-15 Wb +molar gas constant 8.314 472 0.000 015 J mol^-1 K^-1 +molar mass constant 1 e-3 (exact) kg mol^-1 +molar mass of carbon-12 12 e-3 (exact) kg mol^-1 +molar Planck constant 3.990 312 6821 e-10 0.000 000 0057 e-10 J s mol^-1 +molar Planck constant times c 0.119 626 564 72 0.000 000 000 17 J m mol^-1 +molar volume of ideal gas (273.15 K, 100 kPa) 22.710 981 e-3 0.000 040 e-3 m^3 mol^-1 +molar volume of ideal gas (273.15 K, 101.325 kPa) 22.413 996 e-3 0.000 039 e-3 m^3 mol^-1 +molar volume of silicon 12.058 8349 e-6 0.000 0011 e-6 m^3 mol^-1 +Mo x unit 1.002 099 55 e-13 0.000 000 53 e-13 m +muon Compton wavelength 11.734 441 04 e-15 0.000 000 30 e-15 m +muon Compton wavelength over 2 pi 1.867 594 295 e-15 0.000 000 047 e-15 m +muon-electron mass ratio 206.768 2823 0.000 0052 +muon g factor -2.002 331 8414 0.000 000 0012 +muon mag. mom. -4.490 447 86 e-26 0.000 000 16 e-26 J T^-1 +muon mag. mom. anomaly 1.165 920 69 e-3 0.000 000 60 e-3 +muon mag. mom. to Bohr magneton ratio -4.841 970 49 e-3 0.000 000 12 e-3 +muon mag. mom. to nuclear magneton ratio -8.890 597 05 0.000 000 23 +muon mass 1.883 531 30 e-28 0.000 000 11 e-28 kg +muon mass energy equivalent 1.692 833 510 e-11 0.000 000 095 e-11 J +muon mass energy equivalent in MeV 105.658 3668 0.000 0038 MeV +muon mass in u 0.113 428 9256 0.000 000 0029 u +muon molar mass 0.113 428 9256 e-3 0.000 000 0029 e-3 kg mol^-1 +muon-neutron mass ratio 0.112 454 5167 0.000 000 0029 +muon-proton mag. mom. ratio -3.183 345 137 0.000 000 085 +muon-proton mass ratio 0.112 609 5261 0.000 000 0029 +muon-tau mass ratio 5.945 92 e-2 0.000 97 e-2 +natural unit of action 1.054 571 628 e-34 0.000 000 053 e-34 J s +natural unit of action in eV s 6.582 118 99 e-16 0.000 000 16 e-16 eV s +natural unit of energy 8.187 104 38 e-14 0.000 000 41 e-14 J +natural unit of energy in MeV 0.510 998 910 0.000 000 013 MeV +natural unit of length 386.159 264 59 e-15 0.000 000 53 e-15 m +natural unit of mass 9.109 382 15 e-31 0.000 000 45 e-31 kg +natural unit of momentum 2.730 924 06 e-22 0.000 000 14 e-22 kg m s^-1 +natural unit of momentum in MeV/c 0.510 998 910 0.000 000 013 MeV/c +natural unit of time 1.288 088 6570 e-21 0.000 000 0018 e-21 s +natural unit of velocity 299 792 458 (exact) m s^-1 +neutron Compton wavelength 1.319 590 8951 e-15 0.000 000 0020 e-15 m +neutron Compton wavelength over 2 pi 0.210 019 413 82 e-15 0.000 000 000 31 e-15 m +neutron-electron mag. mom. ratio 1.040 668 82 e-3 0.000 000 25 e-3 +neutron-electron mass ratio 1838.683 6605 0.000 0011 +neutron g factor -3.826 085 45 0.000 000 90 +neutron gyromag. ratio 1.832 471 85 e8 0.000 000 43 e8 s^-1 T^-1 +neutron gyromag. ratio over 2 pi 29.164 6954 0.000 0069 MHz T^-1 +neutron mag. mom. -0.966 236 41 e-26 0.000 000 23 e-26 J T^-1 +neutron mag. mom. to Bohr magneton ratio -1.041 875 63 e-3 0.000 000 25 e-3 +neutron mag. mom. to nuclear magneton ratio -1.913 042 73 0.000 000 45 +neutron mass 1.674 927 211 e-27 0.000 000 084 e-27 kg +neutron mass energy equivalent 1.505 349 505 e-10 0.000 000 075 e-10 J +neutron mass energy equivalent in MeV 939.565 346 0.000 023 MeV +neutron mass in u 1.008 664 915 97 0.000 000 000 43 u +neutron molar mass 1.008 664 915 97 e-3 0.000 000 000 43 e-3 kg mol^-1 +neutron-muon mass ratio 8.892 484 09 0.000 000 23 +neutron-proton mag. mom. ratio -0.684 979 34 0.000 000 16 +neutron-proton mass ratio 1.001 378 419 18 0.000 000 000 46 +neutron-tau mass ratio 0.528 740 0.000 086 +neutron to shielded proton mag. mom. ratio -0.684 996 94 0.000 000 16 +Newtonian constant of gravitation 6.674 28 e-11 0.000 67 e-11 m^3 kg^-1 s^-2 +Newtonian constant of gravitation over h-bar c 6.708 81 e-39 0.000 67 e-39 (GeV/c^2)^-2 +nuclear magneton 5.050 783 24 e-27 0.000 000 13 e-27 J T^-1 +nuclear magneton in eV/T 3.152 451 2326 e-8 0.000 000 0045 e-8 eV T^-1 +nuclear magneton in inverse meters per tesla 2.542 623 616 e-2 0.000 000 064 e-2 m^-1 T^-1 +nuclear magneton in K/T 3.658 2637 e-4 0.000 0064 e-4 K T^-1 +nuclear magneton in MHz/T 7.622 593 84 0.000 000 19 MHz T^-1 +Planck constant 6.626 068 96 e-34 0.000 000 33 e-34 J s +Planck constant in eV s 4.135 667 33 e-15 0.000 000 10 e-15 eV s +Planck constant over 2 pi 1.054 571 628 e-34 0.000 000 053 e-34 J s +Planck constant over 2 pi in eV s 6.582 118 99 e-16 0.000 000 16 e-16 eV s +Planck constant over 2 pi times c in MeV fm 197.326 9631 0.000 0049 MeV fm +Planck length 1.616 252 e-35 0.000 081 e-35 m +Planck mass 2.176 44 e-8 0.000 11 e-8 kg +Planck mass energy equivalent in GeV 1.220 892 e19 0.000 061 e19 GeV +Planck temperature 1.416 785 e32 0.000 071 e32 K +Planck time 5.391 24 e-44 0.000 27 e-44 s +proton charge to mass quotient 9.578 833 92 e7 0.000 000 24 e7 C kg^-1 +proton Compton wavelength 1.321 409 8446 e-15 0.000 000 0019 e-15 m +proton Compton wavelength over 2 pi 0.210 308 908 61 e-15 0.000 000 000 30 e-15 m +proton-electron mass ratio 1836.152 672 47 0.000 000 80 +proton g factor 5.585 694 713 0.000 000 046 +proton gyromag. ratio 2.675 222 099 e8 0.000 000 070 e8 s^-1 T^-1 +proton gyromag. ratio over 2 pi 42.577 4821 0.000 0011 MHz T^-1 +proton mag. mom. 1.410 606 662 e-26 0.000 000 037 e-26 J T^-1 +proton mag. mom. to Bohr magneton ratio 1.521 032 209 e-3 0.000 000 012 e-3 +proton mag. mom. to nuclear magneton ratio 2.792 847 356 0.000 000 023 +proton mag. shielding correction 25.694 e-6 0.014 e-6 +proton mass 1.672 621 637 e-27 0.000 000 083 e-27 kg +proton mass energy equivalent 1.503 277 359 e-10 0.000 000 075 e-10 J +proton mass energy equivalent in MeV 938.272 013 0.000 023 MeV +proton mass in u 1.007 276 466 77 0.000 000 000 10 u +proton molar mass 1.007 276 466 77 e-3 0.000 000 000 10 e-3 kg mol^-1 +proton-muon mass ratio 8.880 243 39 0.000 000 23 +proton-neutron mag. mom. ratio -1.459 898 06 0.000 000 34 +proton-neutron mass ratio 0.998 623 478 24 0.000 000 000 46 +proton rms charge radius 0.8768 e-15 0.0069 e-15 m +proton-tau mass ratio 0.528 012 0.000 086 +quantum of circulation 3.636 947 5199 e-4 0.000 000 0050 e-4 m^2 s^-1 +quantum of circulation times 2 7.273 895 040 e-4 0.000 000 010 e-4 m^2 s^-1 +Rydberg constant 10 973 731.568 527 0.000 073 m^-1 +Rydberg constant times c in Hz 3.289 841 960 361 e15 0.000 000 000 022 e15 Hz +Rydberg constant times hc in eV 13.605 691 93 0.000 000 34 eV +Rydberg constant times hc in J 2.179 871 97 e-18 0.000 000 11 e-18 J +Sackur-Tetrode constant (1 K, 100 kPa) -1.151 7047 0.000 0044 +Sackur-Tetrode constant (1 K, 101.325 kPa) -1.164 8677 0.000 0044 +second radiation constant 1.438 7752 e-2 0.000 0025 e-2 m K +shielded helion gyromag. ratio 2.037 894 730 e8 0.000 000 056 e8 s^-1 T^-1 +shielded helion gyromag. ratio over 2 pi 32.434 101 98 0.000 000 90 MHz T^-1 +shielded helion mag. mom. -1.074 552 982 e-26 0.000 000 030 e-26 J T^-1 +shielded helion mag. mom. to Bohr magneton ratio -1.158 671 471 e-3 0.000 000 014 e-3 +shielded helion mag. mom. to nuclear magneton ratio -2.127 497 718 0.000 000 025 +shielded helion to proton mag. mom. ratio -0.761 766 558 0.000 000 011 +shielded helion to shielded proton mag. mom. ratio -0.761 786 1313 0.000 000 0033 +shielded proton gyromag. ratio 2.675 153 362 e8 0.000 000 073 e8 s^-1 T^-1 +shielded proton gyromag. ratio over 2 pi 42.576 3881 0.000 0012 MHz T^-1 +shielded proton mag. mom. 1.410 570 419 e-26 0.000 000 038 e-26 J T^-1 +shielded proton mag. mom. to Bohr magneton ratio 1.520 993 128 e-3 0.000 000 017 e-3 +shielded proton mag. mom. to nuclear magneton ratio 2.792 775 598 0.000 000 030 +speed of light in vacuum 299 792 458 (exact) m s^-1 +standard acceleration of gravity 9.806 65 (exact) m s^-2 +standard atmosphere 101 325 (exact) Pa +Stefan-Boltzmann constant 5.670 400 e-8 0.000 040 e-8 W m^-2 K^-4 +tau Compton wavelength 0.697 72 e-15 0.000 11 e-15 m +tau Compton wavelength over 2 pi 0.111 046 e-15 0.000 018 e-15 m +tau-electron mass ratio 3477.48 0.57 +tau mass 3.167 77 e-27 0.000 52 e-27 kg +tau mass energy equivalent 2.847 05 e-10 0.000 46 e-10 J +tau mass energy equivalent in MeV 1776.99 0.29 MeV +tau mass in u 1.907 68 0.000 31 u +tau molar mass 1.907 68 e-3 0.000 31 e-3 kg mol^-1 +tau-muon mass ratio 16.8183 0.0027 +tau-neutron mass ratio 1.891 29 0.000 31 +tau-proton mass ratio 1.893 90 0.000 31 +Thomson cross section 0.665 245 8558 e-28 0.000 000 0027 e-28 m^2 +triton-electron mag. mom. ratio -1.620 514 423 e-3 0.000 000 021 e-3 +triton-electron mass ratio 5496.921 5269 0.000 0051 +triton g factor 5.957 924 896 0.000 000 076 +triton mag. mom. 1.504 609 361 e-26 0.000 000 042 e-26 J T^-1 +triton mag. mom. to Bohr magneton ratio 1.622 393 657 e-3 0.000 000 021 e-3 +triton mag. mom. to nuclear magneton ratio 2.978 962 448 0.000 000 038 +triton mass 5.007 355 88 e-27 0.000 000 25 e-27 kg +triton mass energy equivalent 4.500 387 03 e-10 0.000 000 22 e-10 J +triton mass energy equivalent in MeV 2808.920 906 0.000 070 MeV +triton mass in u 3.015 500 7134 0.000 000 0025 u +triton molar mass 3.015 500 7134 e-3 0.000 000 0025 e-3 kg mol^-1 +triton-neutron mag. mom. ratio -1.557 185 53 0.000 000 37 +triton-proton mag. mom. ratio 1.066 639 908 0.000 000 010 +triton-proton mass ratio 2.993 717 0309 0.000 000 0025 +unified atomic mass unit 1.660 538 782 e-27 0.000 000 083 e-27 kg +von Klitzing constant 25 812.807 557 0.000 018 ohm +weak mixing angle 0.222 55 0.000 56 +Wien frequency displacement law constant 5.878 933 e10 0.000 010 e10 Hz K^-1 +Wien wavelength displacement law constant 2.897 7685 e-3 0.000 0051 e-3 m K diff --git a/extra/units/imperial/authors.txt b/extra/units/imperial/authors.txt new file mode 100755 index 0000000000..7c1b2f2279 --- /dev/null +++ b/extra/units/imperial/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/extra/units/imperial/imperial-tests.factor b/extra/units/imperial/imperial-tests.factor new file mode 100644 index 0000000000..793fe5679d --- /dev/null +++ b/extra/units/imperial/imperial-tests.factor @@ -0,0 +1,21 @@ +USING: kernel math tools.test units.imperial inverse ; +IN: units.imperial.tests + +[ 1 ] [ 12 inches [ feet ] undo ] unit-test +[ 12 ] [ 1 feet [ inches ] undo ] unit-test + +[ t ] [ 16 ounces 1 pounds = ] unit-test +[ t ] [ 1 pounds [ ounces ] undo 16 = ] unit-test + +[ 1 ] [ 4 quarts [ gallons ] undo ] unit-test +[ 4 ] [ 1 gallons [ quarts ] undo ] unit-test + +[ 2 ] [ 1 pints [ cups ] undo ] unit-test +[ 1 ] [ 2 cups [ pints ] undo ] unit-test + +[ 256 ] [ 1 gallons [ tablespoons ] undo ] unit-test +[ 1 ] [ 256 tablespoons [ gallons ] undo ] unit-test + +[ 768 ] [ 1 gallons [ teaspoons ] undo ] unit-test +[ 1 ] [ 768 teaspoons [ gallons ] undo ] unit-test + diff --git a/extra/units/imperial/imperial.factor b/extra/units/imperial/imperial.factor new file mode 100644 index 0000000000..a0c6350227 --- /dev/null +++ b/extra/units/imperial/imperial.factor @@ -0,0 +1,63 @@ +USING: kernel math prettyprint units units.si inverse ; +IN: units.imperial + +: inches ( n -- dimensioned ) 254/100 * cm ; + +: feet ( n -- dimensioned ) 12 * inches ; + +: yards ( n -- dimensioned ) 3 * feet ; + +: miles ( n -- dimensioned ) 1760 * yards ; + +: nautical-miles ( n -- dimensioned ) 1852 * m ; + +: pounds ( n -- dimensioned ) 22/10 / kg ; + +: ounces ( n -- dimensioned ) 1/16 * pounds ; + +: gallons ( n -- dimensioned ) 379/100 * L ; + +: quarts ( n -- dimensioned ) 1/4 * gallons ; + +: pints ( n -- dimensioned ) 1/2 * quarts ; + +: cups ( n -- dimensioned ) 1/2 * pints ; + +: fluid-ounces ( n -- dimensioned ) 1/16 * pints ; + +: teaspoons ( n -- dimensioned ) 1/6 * fluid-ounces ; + +: tablespoons ( n -- dimensioned ) 1/2 * fluid-ounces ; + +: knots ( n -- dimensioned ) 1852/3600 * m/s ; + +: deg-F ( n -- dimensioned ) 32 - 5/9 * deg-C ; + +: imperial-gallons ( n -- dimensioned ) 454609/100000 * L ; + +: imperial-quarts ( n -- dimensioned ) 1/4 * imperial-gallons ; + +: imperial-pints ( n -- dimensioned ) 1/2 * imperial-quarts ; + +: imperial-fluid-ounces ( n -- dimensioned ) 1/160 * imperial-gallons ; + +: imperial-gill ( n -- dimensioned ) 5 * imperial-fluid-ounces ; + +: dry-gallons ( n -- dimensioned ) 440488377086/100000000000 * L ; + +: dry-quarts ( n -- dimensioned ) 1/4 * dry-gallons ; + +: dry-pints ( n -- dimensioned ) 1/2 * dry-quarts ; + +: pecks ( n -- dimensioned ) 8 * dry-quarts ; + +: bushels ( n -- dimensioned ) 4 * pecks ; + +: rods ( n -- dimensioned ) 11/2 * yards ; + + + + + + +! rod, hogshead, barrel, peck, metric ton, imperial ton.. diff --git a/extra/units/si/authors.txt b/extra/units/si/authors.txt new file mode 100755 index 0000000000..7c1b2f2279 --- /dev/null +++ b/extra/units/si/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/extra/units/si/si-tests.factor b/extra/units/si/si-tests.factor new file mode 100644 index 0000000000..9fb702f050 --- /dev/null +++ b/extra/units/si/si-tests.factor @@ -0,0 +1,13 @@ +USING: kernel tools.test units.si inverse math.constants +math.functions units.imperial ; +IN: units.si.tests + +[ t ] [ 1 m 100 cm = ] unit-test + +[ t ] [ 180 arc-deg [ radians ] undo pi 0.0001 ~ ] unit-test + +[ t ] [ 180 arc-min [ arc-deg ] undo 3 0.0001 ~ ] unit-test + +[ -40 ] [ -40 deg-F [ deg-C ] undo ] unit-test + +[ -40 ] [ -40 deg-C [ deg-F ] undo ] unit-test diff --git a/extra/units/si/si.factor b/extra/units/si/si.factor new file mode 100644 index 0000000000..66f7c1e7a7 --- /dev/null +++ b/extra/units/si/si.factor @@ -0,0 +1,125 @@ +USING: kernel math math.constants sequences units ; +IN: units.si + +! SI Conversions +! http://physics.nist.gov/cuu/Units/ + +! Length +: m ( n -- dimensioned ) { m } { } ; + +! Mass +: kg ( n -- dimensioned ) { kg } { } ; + +! Time +: s ( n -- dimensioned ) { s } { } ; + +! Electric current +: A ( n -- dimensioned ) { A } { } ; + +! Temperature +: K ( n -- dimensioned ) { K } { } ; + +! Amount of substance +: mol ( n -- dimensioned ) { mol } { } ; + +! Luminous intensity +: cd ( n -- dimensioned ) { cd } { } ; + +! SI derived units +: m^2 ( n -- dimensioned ) { m m } { } ; +: m^3 ( n -- dimensioned ) { m m m } { } ; +: m/s ( n -- dimensioned ) { m } { s } ; +: m/s^2 ( n -- dimensioned ) { m } { s s } ; +: 1/m ( n -- dimensioned ) { } { m } ; +: kg/m^3 ( n -- dimensioned ) { kg } { m m m } ; +: A/m^2 ( n -- dimensioned ) { A } { m m } ; +: A/m ( n -- dimensioned ) { A } { m } ; +: mol/m^3 ( n -- dimensioned ) { mol } { m m m } ; +: cd/m^2 ( n -- dimensioned ) { cd } { m m } ; +: kg/kg ( n -- dimensioned ) { kg } { kg } ; + +! Radians are really m/m, and steradians are m^2/m^2 +! but they need to be in reduced form here. +: radians ( n -- radian ) scalar ; +: sr ( n -- steradian ) scalar ; + +: Hz ( n -- hertz ) { } { s } ; +: N ( n -- newton ) { kg m } { s s } ; +: Pa ( n -- pascal ) { kg } { m s s } ; +: J ( n -- joule ) { m m kg } { s s } ; +: W ( n -- watt ) { m m kg } { s s s } ; +: C ( n -- coulomb ) { s A } { } ; +: V ( n -- volt ) { m m kg } { s s s A } ; +: F ( n -- farad ) { s s s s A A } { m m kg } ; +: ohm ( n -- ohm ) { m m kg } { s s s A A } ; +: S ( n -- siemens ) { s s s A A } { m m kg } ; +: Wb ( n -- weber ) { m m kg } { s s A } ; +: T ( n -- tesla ) { kg } { s s A } ; +: H ( n -- henry ) { m m kg } { s s A A } ; +: deg-C ( n -- Celsius ) 27315/100 + { K } { } ; +: lm ( n -- lumen ) { m m cd } { m m } ; +: lx ( n -- lux ) { m m cd } { m m m m } ; +: Bq ( n -- becquerel ) { } { s } ; +: Gy ( n -- gray ) { m m } { s s } ; +: Sv ( n -- sievert ) { m m } { s s } ; +: kat ( n -- katal ) { mol } { s } ; + +! Extensions to the SI +: arc-deg ( n -- x ) pi 180 / * radians ; +: arc-min ( n -- x ) pi 10800 / * radians ; +: arc-sec ( n -- x ) pi 648000 / * radians ; +: L ( n -- liter ) 1/1000 * m^3 ; +: tons ( n -- metric-ton ) 1000 * kg ; +: Np ( n -- neper ) { } { } ; +: B ( n -- bel ) 1.151292546497023 * Np ; +: eV ( n -- electronvolt ) 1.60218e-19 * J ; +: u ( n -- unified-atomic-mass-unit ) 1.66054e-27 * kg ; + +! au has error of 30m, according to wikipedia +: au ( n -- astronomical-unit ) 149597870691 * m ; + +: a ( n -- are ) 100 * m^2 ; +: ha ( n -- hectare ) 10000 * m^2 ; +: bar ( n -- bar ) 100000 * Pa ; +: b ( n -- barn ) 1/10000000000000000000000000000 * m^2 ; +: Ci ( n -- curie ) 37000000000 * Bq ; +: R ( -- dimensioned ) 258/10000 { s A } { kg } ; +: rad ( n -- dimensioned ) 100 / Gy ; + +! roentgen equivalent man, equal to one roentgen of X-rays +: roentgen-equivalent-man ( n -- dimensioned ) 100 / Sv ; + +! inaccurate, use calendar where possible +: minutes ( n -- dimensioned ) 60 * s ; +: hours ( n -- dimensioned ) 60 * minutes ; +: days ( n -- dimensioned ) 24 * hours ; + +! Y Z E P T G M k h da 1 d c m mu n p f a z y +: yotta ( n -- x ) 1000000000000000000000000 * ; +: zetta ( n -- x ) 1000000000000000000000 * ; +: exa ( n -- x ) 1000000000000000000 * ; +: peta ( n -- x ) 1000000000000000 * ; +: tera ( n -- x ) 1000000000000 * ; +: giga ( n -- x ) 1000000000 * ; +: mega ( n -- x ) 1000000 * ; +: kilo ( n -- x ) 1000 * ; +: hecto ( n -- x ) 100 * ; +: deca ( n -- x ) 10 * ; +: deci ( n -- x ) 10 / ; +: centi ( n -- x ) 100 / ; +: milli ( n -- x ) 1000 / ; +: micro ( n -- x ) 1000000 / ; +: nano ( n -- x ) 1000000000 / ; +: pico ( n -- x ) 1000000000000 / ; +: femto ( n -- x ) 1000000000000000 / ; +: atto ( n -- x ) 1000000000000000000 / ; +: zepto ( n -- x ) 1000000000000000000000 / ; +: yocto ( n -- x ) 1000000000000000000000000 / ; + +: km ( n -- dimensioned ) kilo m ; +: cm ( n -- dimensioned ) centi m ; +: mm ( n -- dimensioned ) milli m ; +: nm ( n -- dimensioned ) nano m ; +: g ( n -- dimensioned ) milli kg ; +: ms ( n -- dimensioned ) milli s ; +: angstrom ( n -- dimensioned ) 10 / nm ; diff --git a/extra/units/units-tests.factor b/extra/units/units-tests.factor new file mode 100755 index 0000000000..9b450ed18b --- /dev/null +++ b/extra/units/units-tests.factor @@ -0,0 +1,21 @@ +USING: arrays kernel math sequences tools.test units.si +units.imperial units inverse math.functions ; +IN: units.tests + +[ T{ dimensioned f 3 { m } { } } ] [ 3 m ] unit-test +[ T{ dimensioned f 3 { m } { s } } ] [ 3 m/s ] unit-test +[ T{ dimensioned f 4000 { m } { } } ] [ 4 km ] unit-test + +[ t ] [ 4 m 5 m d+ 9 m = ] unit-test +[ t ] [ 5 m 1 m d- 4 m = ] unit-test +[ t ] [ 5 m 2 m d* 10 m^2 = ] unit-test +[ t ] [ 5 m 2 m d/ 5/2 { } { } = ] unit-test +[ t ] [ 5 m 2 m tuck d/ drop 2 m = ] unit-test + +[ t ] [ 1 m 2 m 3 m 3array d-product 6 m^3 = ] unit-test +[ t ] [ 3 m d-recip 1/3 { } { m } = ] unit-test + +: km/L km 1 L d/ ; +: mpg miles 1 gallons d/ ; + +[ t ] [ 100 10 / km/L [ mpg ] undo 23 1 ~ ] unit-test diff --git a/extra/units/units.factor b/extra/units/units.factor new file mode 100755 index 0000000000..7604108b82 --- /dev/null +++ b/extra/units/units.factor @@ -0,0 +1,102 @@ +USING: accessors arrays io kernel math namespaces splitting +prettyprint sequences sorting vectors words inverse summary +shuffle math.functions sets ; +IN: units + +TUPLE: dimensioned value top bot ; + +TUPLE: dimensions-not-equal ; + +: dimensions-not-equal ( -- * ) + \ dimensions-not-equal new throw ; + +M: dimensions-not-equal summary drop "Dimensions do not match" ; + +: remove-one ( seq obj -- seq ) + 1array split1 append ; + +: 2remove-one ( seq seq obj -- seq seq ) + [ remove-one ] curry bi@ ; + +: symbolic-reduce ( seq seq -- seq seq ) + 2dup intersect dup empty? + [ drop ] [ first 2remove-one symbolic-reduce ] if ; + +: ( n top bot -- obj ) + symbolic-reduce + [ natural-sort ] bi@ + dimensioned boa ; + +: >dimensioned< ( d -- n top bot ) + [ value>> ] [ top>> ] [ bot>> ] tri ; + +\ [ >dimensioned< ] define-inverse + +: dimensions ( dimensioned -- top bot ) + [ top>> ] [ bot>> ] bi ; + +: check-dimensions ( d d -- ) + [ dimensions 2array ] bi@ = + [ dimensions-not-equal ] unless ; + +: 2values ( dim dim -- val val ) [ value>> ] bi@ ; + +: ( top bot val -- dim ) + -rot ; + +: d+ ( d d -- d ) ; + +: d- ( d d -- d ) ; + +: scalar ( n -- d ) + { } { } ; + +: d* ( d d -- d ) + [ dup number? [ scalar ] when ] bi@ + [ [ top>> ] bi@ append ] 2keep + [ [ bot>> ] bi@ append ] 2keep + 2values * dimension-op> ; + +: d-neg ( d -- d ) -1 d* ; + +: d-sq ( d -- d ) dup d* ; + +: d-recip ( d -- d' ) + >dimensioned< spin recip dimension-op> ; + +: d/ ( d d -- d ) d-recip d* ; + +: comparison-op ( d d -- n n ) 2dup check-dimensions 2values ; + +: d< ( d d -- ? ) comparison-op < ; + +: d<= ( d d -- ? ) comparison-op <= ; + +: d> ( d d -- ? ) comparison-op > ; + +: d>= ( d d -- ? ) comparison-op >= ; + +: d= ( d d -- ? ) comparison-op number= ; + +: d~ ( d d delta -- ? ) >r comparison-op r> ~ ; + +: d-min ( d d -- d ) [ d< ] most ; + +: d-max ( d d -- d ) [ d> ] most ; + +: d-product ( v -- d ) 1 scalar [ d* ] reduce ; + +: d-sum ( v -- d ) unclip-slice [ d+ ] reduce ; + +: d-infimum ( v -- d ) unclip-slice [ d-min ] reduce ; + +: d-supremum ( v -- d ) unclip-slice [ d-max ] reduce ; + +\ d+ [ d- ] [ d- ] define-math-inverse +\ d- [ d+ ] [ d- ] define-math-inverse +\ d* [ d/ ] [ d/ ] define-math-inverse +\ d/ [ d* ] [ d/ ] define-math-inverse +\ d-recip [ d-recip ] define-inverse diff --git a/extra/x/widgets/wm/frame/frame.factor b/extra/x/widgets/wm/frame/frame.factor index b75671fa3c..d20c5bf672 100755 --- a/extra/x/widgets/wm/frame/frame.factor +++ b/extra/x/widgets/wm/frame/frame.factor @@ -4,7 +4,7 @@ USING: kernel io combinators namespaces quotations arrays sequences x11.xlib x11.constants mortar mortar.sugar slot-accessors geom.rect - math.bitfields + math.bitwise x x.gc x.widgets x.widgets.button x.widgets.wm.child diff --git a/extra/xml/syntax/syntax.factor b/extra/xml/syntax/syntax.factor new file mode 100644 index 0000000000..283efa8412 --- /dev/null +++ b/extra/xml/syntax/syntax.factor @@ -0,0 +1,58 @@ +! Copyright (C) 2008 Daniel Ehrenberg. +! See http://factorcode.org/license.txt for BSD license. +USING: lexer parser splitting kernel quotations namespaces +sequences assocs sequences.lib xml.generator xml.utilities +xml.data ; +IN: xml.syntax + +: parsed-name ( accum -- accum ) + scan ":" split1 [ f ] [ ] if* parsed ; + +: run-combinator ( accum quot1 quot2 -- accum ) + >r [ ] like parsed r> [ parsed ] each ; + +: parse-tag-contents ( accum contained? -- accum ) + [ \ contained*, parsed ] [ + scan-word \ [ = + [ POSTPONE: [ \ tag*, parsed ] + [ "Expected [ missing" throw ] if + ] if ; + +DEFER: >> + +: attributes-parsed ( accum quot -- accum ) + dup empty? [ drop f parsed ] [ + >r \ >r parsed r> parsed + [ H{ } make-assoc r> swap ] [ parsed ] each + ] if ; + +: << + parsed-name [ + \ >> parse-until >quotation + attributes-parsed \ contained? get + ] with-scope parse-tag-contents ; parsing + +: == + \ call parsed parsed-name \ set parsed ; parsing + +: // + \ contained? on ; parsing + +: parse-special ( accum end-token word -- accum ) + >r parse-tokens " " join parsed r> parsed ; + +: " \ comment, parse-special ; parsing + +: " \ directive, parse-special ; parsing + +: " \ instruction, parse-special ; parsing + +: >xml-document ( seq -- xml ) + dup first prolog? [ unclip-slice ] [ standard-prolog ] if swap + [ tag? ] split-around ; + +DEFER: XML> + +: [ >quotation ] parse-literal + { } parsed \ make parsed \ >xml-document parsed ; parsing