{ $description "Creates and registers an alarm. If " { $snippet "frequency" } " is " { $link f } ", this will be a one-time alarm, otherwise it will fire with the given frequency. The quotation will be called from the alarm thread." } ;\r
\r
HELP: later\r
-{ $values { "quot" quotation } { "dt" duration } { "alarm" alarm } }\r
+{ $values { "quot" quotation } { "duration" duration } { "alarm" alarm } }\r
{ $description "Creates and registers an alarm which calls the quotation once at " { $snippet "time" } " from now." } ;\r
\r
HELP: cancel-alarm\r
{ $values { "alarm" alarm } }\r
{ $description "Cancels an alarm. Does nothing if the alarm is not active." } ;\r
\r
+HELP: every\r
+{ $values\r
+ { "quot" quotation } { "duration" duration }\r
+ { "alarm" alarm } }\r
+{ $description "Creates and registers an alarm which calls the quotation repeatedly, using " { $snippet "dt" } " as the frequency." } ;\r
+\r
ARTICLE: "alarms" "Alarms"\r
"Alarms provide a lightweight way to schedule one-time and recurring tasks without spawning a new thread."\r
{ $subsection alarm }\r
: add-alarm ( quot time frequency -- alarm )
<alarm> [ register-alarm ] keep ;
-: later ( quot dt -- alarm )
+: later ( quot duration -- alarm )
hence f add-alarm ;
-: every ( quot dt -- alarm )
+: every ( quot duration -- alarm )
[ hence ] keep add-alarm ;
: cancel-alarm ( alarm -- )
INSTANCE: bit-array sequence
M: bit-array pprint-delims drop \ ?{ \ } ;
-
M: bit-array >pprint-sequence ;
+M: bit-array pprint* pprint-object ;
: ?V{ \ } [ >bit-vector ] parse-literal ; parsing\r
\r
M: bit-vector >pprint-sequence ;\r
-\r
M: bit-vector pprint-delims drop \ ?V{ \ } ;\r
+M: bit-vector pprint* pprint-object ;\r
{ $description "Returns a timestamp object representing the start of the specified day in your current timezone." }
{ $examples
{ $example "USING: calendar prettyprint ;"
- "12 25 2010 <date> ."
- "T{ timestamp f 12 25 2010 0 0 0 T{ duration f 0 0 0 -5 0 0 } }"
+ "2010 12 25 <date> ."
+ "T{ timestamp\n { year 2010 }\n { month 12 }\n { day 25 }\n { gmt-offset T{ duration { hour -5 } } }\n}"
}
} ;
! 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 ;
--- /dev/null
+Doug Coleman
--- /dev/null
+! 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 <string> %
+ 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
--- /dev/null
+Some code shared by MD5, SHA1 and SHA2 implementations
-! 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
+
<PRIVATE
SYMBOLS: a b c d old-a old-b old-c old-d ;
-USING: arrays combinators crypto.common kernel io
-io.encodings.binary io.files io.streams.byte-array math.vectors
-strings sequences namespaces math parser sequences vectors
-io.binary hashtables symbols math.bitfields.lib checksums ;
+! Copyright (C) 2006, 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays combinators kernel io io.encodings.binary io.files
+io.streams.byte-array math.vectors strings sequences namespaces
+math parser sequences assocs grouping vectors io.binary hashtables
+symbols math.bitwise checksums checksums.common ;
IN: checksums.sha1
! Implemented according to RFC 3174.
{ 3 [ bitxor bitxor ] }
} case ;
+: nth-int-be ( string n -- int )
+ 4 * dup 4 + rot <slice> 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
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
+ [ zero? ] trim-left
dup length odd? [ rest ] when
seq>2seq [ sha1 checksum-bytes ] bi@
2seq>seq ;
-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
<PRIVATE
[ -11 bitroll-32 ] keep
-25 bitroll-32 bitxor bitxor ; inline
+: slice3 ( n seq -- a b c ) >r dup 3 + r> <slice> first3 ; inline
+
: T1 ( W n -- T1 )
[ swap nth ] keep
K get nth +
: 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 <string> %
+ 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
! 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
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
: phantom-shuffle ( shuffle -- )
[ in>> length phantom-datastack get phantom-input ] keep
- shuffle* phantom-datastack get phantom-append ;
+ shuffle phantom-datastack get phantom-append ;
: phantom->r ( n -- )
phantom-datastack get phantom-input
: eliminate-phi-introductions ( introductions seq terminated -- seq' )
[
[ nip ] [
- dup [ +bottom+ eq? ] left-trim
+ dup [ +bottom+ eq? ] trim-left
[ [ length ] bi@ - tail* ] keep append
] if
] 3map ;
! 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 , ;
! 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
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
! 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 -- )
: 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 ;
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
! 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 ;
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
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 -- )
] 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 [
dup dup class <select-by-slots-statement> do-select ;
: select-tuple ( tuple -- tuple/f )
- dup dup class \ query new 1 >>limit <query> do-select ?first ;
+ dup dup class \ query new 1 >>limit <query> do-select
+ [ f ] [ first ] if-empty ;
: do-count ( exemplar-tuple statement -- tuples )
[
! 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 ;
: F{ \ } [ >float-array ] parse-literal ; parsing
M: float-array pprint-delims drop \ F{ \ } ;
-
M: float-array >pprint-sequence ;
+M: float-array pprint* pprint-object ;
USING: hints math.vectors arrays ;
: FV{ \ } [ >float-vector ] parse-literal ; parsing\r
\r
M: float-vector >pprint-sequence ;\r
-\r
M: float-vector pprint-delims drop \ FV{ \ } ;\r
+M: float-vector pprint* pprint-object ;\r
{ $subsection $link }
{ $subsection $vocab-link }
{ $subsection $snippet }
+{ $subsection $slot }
{ $subsection $url } ;
ARTICLE: "block-elements" "Block elements"
{ $markup-example { $code "2 2 + ." } }
} ;
+HELP: $nl
+{ $values { "children" "unused parameter" } }
+{ $description "Prints a paragraph break. The parameter is unused." } ;
+
+HELP: $snippet
+{ $values { "children" "markup elements" } }
+{ $description "Prints a key word or otherwise notable snippet of text, such as a type or a word input parameter. To document slot names, use " { $link $slot } "." } ;
+
+HELP: $slot
+{ $values { "children" "markup elements" } }
+{ $description "Prints a tuple slot name in the same way as a snippet. The help tool can check that there exists an accessor with this name." } ;
+
HELP: $vocabulary
{ $values { "element" "a markup element of the form " { $snippet "{ word }" } } }
{ $description "Prints a word's vocabulary. This markup element is automatically output by the help system, so help descriptions of parsing words should not call it." } ;
USING: accessors arrays definitions generic io kernel assocs
hashtables namespaces parser prettyprint sequences strings
io.styles vectors words math sorting splitting classes slots
-vocabs help.stylesheet help.topics vocabs.loader ;
+vocabs help.stylesheet help.topics vocabs.loader alias ;
IN: help.markup
! Simple markup language.
: $snippet ( children -- )
[ snippet-style get print-element* ] ($span) ;
+! for help-lint
+ALIAS: $slot $snippet
+
: $emphasis ( children -- )
[ emphasis-style get print-element* ] ($span) ;
! 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 ;
+++ /dev/null
-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 ;
-
-: <link> ( 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 ;
+++ /dev/null
-Doug Coleman
+++ /dev/null
-Doug Coleman
+++ /dev/null
-USING: html.parser kernel tools.test ;
-IN: html.parser.tests
-
-[
- V{ T{ tag f "html" H{ } f f } }
-] [ "<html>" parse-html ] unit-test
-
-[
- V{ T{ tag f "html" H{ } f t } }
-] [ "</html>" parse-html ] unit-test
-
-[
- V{ T{ tag f "a" H{ { "href" "http://factorcode.org/" } } f f } }
-] [ "<a href=\"http://factorcode.org/\">" parse-html ] unit-test
-
-[
- V{ T{ tag f "a" H{ { "href" "http://factorcode.org/" } } f f } }
-] [ "<a href = \"http://factorcode.org/\" >" parse-html ] unit-test
-
-[
-V{
- T{
- tag
- f
- "a"
- H{ { "baz" "\"quux\"" } { "foo" "bar's" } }
- f
- f
- }
-}
-] [ "<a foo=\"bar's\" baz='\"quux\"' >" parse-html ] unit-test
-
-[
-V{
- T{ tag f "a"
- H{
- { "a" "pirsqd" }
- { "foo" "bar" }
- { "href" "http://factorcode.org/" }
- { "baz" "quux" }
- } f f }
-}
-] [ "<a href = \"http://factorcode.org/\" foo = bar baz='quux'a=pirsqd >" 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 }
-}
-] [ "<html<head</head</html" parse-html ] unit-test
-
-[
-V{
- T{ tag f "head" H{ } f f }
- T{ tag f "title" H{ } f f }
- T{ tag f text f "Spagna" f }
- T{ tag f "title" H{ } f t }
- T{ tag f "head" H{ } f t }
-}
-] [ "<head<title>Spagna</title></head" parse-html ] unit-test
+++ /dev/null
-USING: accessors arrays html.parser.utils hashtables io kernel
-namespaces prettyprint quotations
-sequences splitting state-parser strings unicode.categories unicode.case
-sequences.lib ;
-IN: html.parser
-
-TUPLE: tag name attributes text closing? ;
-
-SINGLETON: text
-SINGLETON: dtd
-SINGLETON: comment
-SYMBOL: tagstack
-
-: push-tag ( tag -- )
- tagstack get push ;
-
-: closing-tag? ( string -- ? )
- [ f ]
- [ [ first ] [ peek ] bi [ CHAR: / = ] bi@ or ] if-empty ;
-
-: <tag> ( name attributes closing? -- tag )
- tag new
- swap >>closing?
- swap >>attributes
- swap >>name ;
-
-: make-tag ( string attribs -- tag )
- >r [ closing-tag? ] keep "/" trim1 r> rot <tag> ;
-
-: 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 ;
+++ /dev/null
-Doug Coleman
+++ /dev/null
-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 text>> write "-->" write ;
-
-M: html-printer print-dtd-tag ( tag -- )
- "<!" write text>> 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
- name>> 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 <repetition> write ;
-
-M: html-prettyprinter print-opening-tag ( tag -- )
- print-tabs "<" write
- name>> write
- ">\n" write ;
-
-M: html-prettyprinter print-closing-tag ( tag -- )
- "</" write
- name>> write
- ">" write ;
+++ /dev/null
-Doug Coleman
+++ /dev/null
-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
-
+++ /dev/null
-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 <circular-string>
- [ 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? ;
USING: accessors kernel sequences combinators kernel namespaces
classes.tuple assocs splitting words arrays memoize
io io.files io.encodings.utf8 io.streams.string
-unicode.case tuple-syntax mirrors fry math urls present
+unicode.case mirrors fry math urls present
multiline xml xml.data xml.writer xml.utilities
html.forms
html.elements
USING: accessors kernel sequences combinators kernel namespaces
classes.tuple assocs splitting words arrays memoize parser lexer
io io.files io.encodings.utf8 io.streams.string
-unicode.case tuple-syntax mirrors fry math urls
+unicode.case mirrors fry math urls
multiline xml xml.data xml.writer xml.utilities
html.elements
html.components
USING: http.client http.client.private http tools.test
-tuple-syntax namespaces urls ;
+namespaces urls ;
[ "localhost" f ] [ "localhost" parse-host ] unit-test
[ "localhost" 8888 ] [ "localhost:8888" parse-host ] unit-test
[ "www.arc.com" ] [ "http://www.arc.com////" download-name ] unit-test
[
- TUPLE{ request
- url: TUPLE{ url protocol: "http" host: "www.apple.com" port: 80 path: "/index.html" }
- method: "GET"
- version: "1.1"
- cookies: V{ }
- header: H{ { "connection" "close" } { "user-agent" "Factor http.client" } }
+ T{ request
+ { url T{ url { protocol "http" } { host "www.apple.com" } { port 80 } { path "/index.html" } } }
+ { method "GET" }
+ { version "1.1" }
+ { cookies V{ } }
+ { header H{ { "connection" "close" } { "user-agent" "Factor http.client" } } }
}
] [
"http://www.apple.com/index.html"
] unit-test
[
- TUPLE{ request
- url: TUPLE{ url protocol: "https" host: "www.amazon.com" port: 443 path: "/index.html" }
- method: "GET"
- version: "1.1"
- cookies: V{ }
- header: H{ { "connection" "close" } { "user-agent" "Factor http.client" } }
+ T{ request
+ { url T{ url { protocol "https" } { host "www.amazon.com" } { port 443 } { path "/index.html" } } }
+ { method "GET" }
+ { version "1.1" }
+ { cookies V{ } }
+ { header H{ { "connection" "close" } { "user-agent" "Factor http.client" } } }
}
] [
"https://www.amazon.com/index.html"
PRIVATE>
: read-chunk-size ( -- n )
- read-crlf ";" split1 drop [ blank? ] right-trim
+ read-crlf ";" split1 drop [ blank? ] trim-right
hex> [ "Bad chunk size" throw ] unless* ;
: read-chunks ( -- )
USING: http http.server http.client tools.test multiline
-tuple-syntax io.streams.string io.encodings.utf8
-io.encodings.8-bit io.encodings.binary io.encodings.string
-kernel arrays splitting sequences assocs io.sockets db db.sqlite
-continuations urls hashtables accessors ;
+io.streams.string io.encodings.utf8 io.encodings.8-bit
+io.encodings.binary io.encodings.string kernel arrays splitting
+sequences assocs io.sockets db db.sqlite continuations urls
+hashtables accessors ;
IN: http.tests
[ "text/plain" latin1 ] [ "text/plain" parse-content-type ] unit-test
;
[
- TUPLE{ request
- url: TUPLE{ url path: "/bar" }
- method: "POST"
- version: "1.1"
- header: H{ { "some-header" "1; 2" } { "content-length" "4" } { "content-type" "application/octet-stream" } }
- post-data: TUPLE{ post-data content: "blah" raw: "blah" content-type: "application/octet-stream" }
- cookies: V{ }
+ T{ request
+ { url T{ url { path "/bar" } } }
+ { method "POST" }
+ { version "1.1" }
+ { header H{ { "some-header" "1; 2" } { "content-length" "4" } { "content-type" "application/octet-stream" } } }
+ { post-data T{ post-data { content "blah" } { raw "blah" } { content-type "application/octet-stream" } } }
+ { cookies V{ } }
}
] [
read-request-test-1 lf>crlf [
;
[
- TUPLE{ request
- url: TUPLE{ url host: "www.sex.com" path: "/bar" }
- method: "HEAD"
- version: "1.1"
- header: H{ { "host" "www.sex.com" } }
- cookies: V{ }
+ T{ request
+ { url T{ url { host "www.sex.com" } { path "/bar" } } }
+ { method "HEAD" }
+ { version "1.1" }
+ { header H{ { "host" "www.sex.com" } } }
+ { cookies V{ } }
}
] [
read-request-test-2 lf>crlf [
;
[
- TUPLE{ response
- version: "1.1"
- code: 404
- message: "not found"
- header: H{ { "content-type" "text/html; charset=UTF-8" } }
- cookies: { }
- content-type: "text/html"
- content-charset: utf8
+ T{ response
+ { version "1.1" }
+ { code 404 }
+ { message "not found" }
+ { header H{ { "content-type" "text/html; charset=UTF-8" } } }
+ { cookies { } }
+ { content-type "text/html" }
+ { content-charset utf8 }
}
] [
read-response-test-1 lf>crlf
! 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
: (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 )
[ file-responder get hook>> call ] [ 2drop <304> ] if ;\r
\r
: serving-path ( filename -- filename )\r
- file-responder get root>> right-trim-separators\r
+ file-responder get root>> trim-right-separators\r
"/"\r
- rot "" or left-trim-separators 3append ;\r
+ rot "" or trim-left-separators 3append ;\r
\r
: serve-file ( filename -- response )\r
dup mime-type\r
"m" get next-change drop
dup print flush
dup parent-directory
- [ right-trim-separators "xyz" tail? ] either? not
+ [ trim-right-separators "xyz" tail? ] either? not
] loop
"c1" get count-down
"m" get next-change drop
dup print flush
dup parent-directory
- [ right-trim-separators "yxy" tail? ] either? not
+ [ trim-right-separators "yxy" tail? ] either? not
] loop
"c2" get count-down
"0.0.0.0" or
rot inet-pton *uint over set-sockaddr-in-addr ;
-<PRIVATE
-
-SYMBOL: port-override
-
-: (port) ( port -- port' ) port-override get swap or ;
-
-PRIVATE>
-
M: inet4 parse-sockaddr
>r dup sockaddr-in-addr <uint> r> inet-ntop
- swap sockaddr-in-port ntohs (port) <inet4> ;
+ swap sockaddr-in-port ntohs <inet4> ;
TUPLE: inet6 host port ;
M: inet6 parse-sockaddr
>r dup sockaddr-in6-addr r> inet-ntop
- swap sockaddr-in6-port ntohs (port) <inet6> ;
+ swap sockaddr-in6-port ntohs <inet6> ;
: addrspec-of-family ( af -- addrspec )
{
[ addrinfo>addrspec ] map
sift ;
-: prepare-resolve-host ( addrspec -- host' serv' flags )
- #! If the port is a number, we resolve for 'http' then
- #! change it later. This is a workaround for a FreeBSD
- #! getaddrinfo() limitation -- on Windows, Linux and Mac,
- #! we can convert a number to a string and pass that as the
- #! service name, but on FreeBSD this gives us an unknown
- #! service error.
- [ host>> ]
- [ port>> dup integer? [ port-override set "http" ] when ] bi
- over 0 AI_PASSIVE ? ;
-
HOOK: addrinfo-error io-backend ( n -- )
GENERIC: resolve-host ( addrspec -- seq )
C: <inet> inet
+: resolve-passive-host ( -- addrspecs )
+ { T{ inet6 f "::" f } T{ inet4 f "0.0.0.0" f } } [ clone ] map ;
+
+: prepare-addrinfo ( -- addrinfo )
+ "addrinfo" <c-object>
+ PF_UNSPEC over set-addrinfo-family
+ IPPROTO_TCP over set-addrinfo-protocol ;
+
+: fill-in-ports ( addrspecs port -- addrspecs )
+ [ >>port ] curry map ;
+
M: inet resolve-host
- [
- prepare-resolve-host
- "addrinfo" <c-object>
- [ set-addrinfo-flags ] keep
- PF_UNSPEC over set-addrinfo-family
- IPPROTO_TCP over set-addrinfo-protocol
- f <void*> [ getaddrinfo addrinfo-error ] keep *void*
- [ parse-addrinfo-list ] keep
- freeaddrinfo
- ] with-scope ;
+ [ port>> ] [ host>> ] bi [
+ f prepare-addrinfo f <void*>
+ [ getaddrinfo addrinfo-error ] keep *void*
+ [ parse-addrinfo-list ] keep freeaddrinfo
+ ] [ resolve-passive-host ] if*
+ swap fill-in-ports ;
M: f resolve-host drop { } ;
! 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 ;
-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
! 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
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
! 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
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 )
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
[ t ] [ "\\\\" root-directory? ] unit-test
[ t ] [ "/" root-directory? ] unit-test
[ t ] [ "//" root-directory? ] unit-test
-[ t ] [ "c:\\" right-trim-separators root-directory? ] unit-test
-[ t ] [ "Z:\\" right-trim-separators root-directory? ] unit-test
+[ t ] [ "c:\\" trim-right-separators root-directory? ] unit-test
+[ t ] [ "Z:\\" trim-right-separators root-directory? ] unit-test
[ f ] [ "c:\\foo" root-directory? ] unit-test
[ f ] [ "." root-directory? ] unit-test
[ f ] [ ".." root-directory? ] unit-test
{
{ [ dup empty? ] [ f ] }
{ [ dup [ path-separator? ] all? ] [ t ] }
- { [ dup right-trim-separators { [ length 2 = ] [ second CHAR: : = ] } 1&& ] [ t ] }
+ { [ dup trim-right-separators { [ length 2 = ] [ second CHAR: : = ] } 1&& ] [ t ] }
[ f ]
} cond nip ;
! 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
! 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
USING: alien alien.c-types alien.syntax arrays continuations\r
destructors generic io.mmap io.ports io.windows io.windows.files\r
-kernel libc math math.bitfields namespaces quotations sequences windows\r
+kernel libc math math.bitwise namespaces quotations sequences windows\r
windows.advapi32 windows.kernel32 io.backend system accessors\r
io.windows.privileges ;\r
IN: io.windows.nt.privileges\r
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 ? -- )
USING: sequences kernel math locals math.order math.ranges\r
-accessors combinators.lib arrays namespaces combinators\r
-combinators.short-circuit ;\r
+accessors arrays namespaces combinators combinators.short-circuit ;\r
IN: lcs\r
\r
<PRIVATE\r
dup array? [ dup length 1 = [ first ] when ] when\r
dup string? [\r
[\r
- string-limit off\r
+ string-limit? off\r
1 line-limit set\r
3 nesting-limit set\r
0 margin set\r
! See http://factorcode.org/license.txt for BSD license.\r
USING: accessors peg peg.parsers memoize kernel sequences\r
logging arrays words strings vectors io io.files io.encodings.utf8\r
-namespaces combinators combinators.lib logging.server\r
-calendar calendar.format ;\r
+namespaces combinators logging.server calendar calendar.format ;\r
IN: logging.parser\r
\r
TUPLE: log-entry date level word-name message ;\r
--- /dev/null
+Chris Double
--- /dev/null
+! Copyright (C) 2006 Chris Double.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax namespaces assocs sequences
+kernel combinators ;
+IN: match
+
+HELP: match
+{ $values { "value1" object } { "value2" object } { "bindings" assoc }
+}
+{ $description "Pattern match value1 against value2. These values can be any Factor value, including sequences and tuples. The values can contain pattern variables, which are symbols that begin with '?'. The result is a hashtable of the bindings, mapping the pattern variables from one sequence to the equivalent value in the other sequence. The '_' symbol can be used to ignore the value at that point in the pattern for the match. " }
+{ $examples
+ { $unchecked-example "USE: match" "MATCH-VARS: ?a ?b ;\n{ ?a { 2 ?b } 5 } { 1 { 2 3 } _ } match ." "H{ { ?a 1 } { ?b 3 } }" }
+}
+{ $see-also match-cond POSTPONE: MATCH-VARS: replace-patterns match-replace } ;
+
+HELP: match-cond
+{ $values { "assoc" "a sequence of pairs" } }
+{ $description "Calls the second quotation in the first pair whose first sequence yields a successful " { $link match } " against the top of the stack. The second quotation, when called, has the hashtable returned from the " { $link match } " call bound as the top namespace so " { $link get } " can be used to retrieve the values. To have a fallthrough match clause use the '_' match variable." }
+{ $examples
+ { $code "USE: match" "MATCH-VARS: ?value ;\n{ increment ?value } {\n { { increment ?value } [ ?value do-something ] }\n { { decrement ?value } [ ?value do-something-else ] }\n { _ [ no-match-found ] }\n} match-cond" }
+}
+{ $see-also match POSTPONE: MATCH-VARS: replace-patterns match-replace } ;
+
+
+HELP: MATCH-VARS:
+{ $syntax "MATCH-VARS: var ... ;" }
+{ $values { "var" "a match variable name beginning with '?'" } }
+{ $description "Creates a symbol that can be used in " { $link match } " and " { $link match-cond } " for binding values in the matched sequence. The symbol name is created as a word that is defined to get the value of the symbol out of the current namespace. This can be used in " { $link match-cond } " to retrive the values in the quotation body." }
+{ $examples
+ { $code "USE: match" "MATCH-VARS: ?value ;\n{ increment ?value } {\n { { increment ?value } [ ?value do-something ] }\n { { decrement ?value } [ ?value do-something-else ] }\n { _ [ no-match-found ] }\n} match-cond" }
+}
+{ $see-also match match-cond replace-patterns match-replace } ;
+
+HELP: replace-patterns
+{ $values { "object" object } { "result" object } }
+{ $description "Copy the object, replacing each occurrence of a pattern matching variable with the actual value of that variable." }
+{ $see-also match-cond POSTPONE: MATCH-VARS: match-replace } ;
+
+HELP: match-replace
+{ $values { "object" object } { "pattern1" object } { "pattern2" object } { "result" object } }
+{ $description "Matches the " { $snippet "object" } " against " { $snippet "pattern1" } ". The pattern match variables in " { $snippet "pattern1" } " are assigned the values from the matching " { $snippet "object" } ". These are then replaced into the " { $snippet "pattern2" } " pattern match variables." }
+{ $examples
+ { $example
+ "USING: match prettyprint ;"
+ "IN: scratchpad"
+ "MATCH-VARS: ?a ?b ;"
+ "{ 1 2 } { ?a ?b } { ?b ?a } match-replace ."
+ "{ 2 1 }"
+ }
+}
+{ $see-also match-cond POSTPONE: MATCH-VARS: } ;
+
+ARTICLE: "match" "Pattern matching"
+"The " { $vocab-link "match" } " vocabulary implements ML-style pattern matching."
+$nl
+"Variables used for pattern matching must be explicitly defined first:"
+{ $subsection POSTPONE: MATCH-VARS: }
+"A basic pattern match:"
+{ $subsection match }
+"A conditional form analogous to " { $link cond } ":"
+{ $subsection match-cond }
+"Pattern replacement:"
+{ $subsection match-replace } ;
+
+ABOUT: "match"
--- /dev/null
+! Copyright (C) 2006 Chris Double.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test match namespaces arrays ;
+IN: match.tests
+
+MATCH-VARS: ?a ?b ;
+
+[ f ] [ { ?a ?a } { 1 2 } match ] unit-test
+
+[ H{ { ?a 1 } { ?b 2 } } ] [
+ { ?a ?b } { 1 2 } match
+] unit-test
+
+[ { 1 2 } ] [
+ { 1 2 }
+ {
+ { { ?a ?b } [ ?a ?b 2array ] }
+ } match-cond
+] unit-test
+
+[ t ] [
+ { 1 2 }
+ {
+ { { 1 2 } [ t ] }
+ { f [ f ] }
+ } match-cond
+] unit-test
+
+[ t ] [
+ { 1 3 }
+ {
+ { { 1 2 } [ t ] }
+ { { 1 3 } [ t ] }
+ } match-cond
+] unit-test
+
+[ f ] [
+ { 1 5 }
+ {
+ { { 1 2 } [ t ] }
+ { { 1 3 } [ t ] }
+ { _ [ f ] }
+ } match-cond
+] unit-test
+
+TUPLE: foo a b ;
+
+C: <foo> foo
+
+{ 1 2 } [
+ 1 2 <foo> T{ foo f ?a ?b } match [
+ ?a ?b
+ ] bind
+] unit-test
+
+{ 1 2 } [
+ 1 2 <foo> \ ?a \ ?b <foo> match [
+ ?a ?b
+ ] bind
+] unit-test
+
+{ H{ { ?a ?a } } } [
+ \ ?a \ ?a match
+] unit-test
+
+[ "match" ] [
+ "abcd" {
+ { ?a [ "match" ] }
+ } match-cond
+] unit-test
+
+[
+ { 2 1 }
+] [
+ { "a" 1 2 "b" } { _ ?a ?b _ } { ?b ?a } match-replace
+] unit-test
+
+TUPLE: match-replace-test a b ;
+
+[
+ T{ match-replace-test f 2 1 }
+] [
+ T{ match-replace-test f 1 2 }
+ T{ match-replace-test f ?a ?b }
+ T{ match-replace-test f ?b ?a }
+ match-replace
+] unit-test
--- /dev/null
+! Copyright (C) 2006 Chris Double.
+! See http://factorcode.org/license.txt for BSD license.
+!
+! Based on pattern matching code from Paul Graham's book 'On Lisp'.
+USING: parser lexer kernel words namespaces sequences classes.tuple
+combinators macros assocs math effects ;
+IN: match
+
+SYMBOL: _
+
+: define-match-var ( name -- )
+ create-in
+ dup t "match-var" set-word-prop
+ dup [ get ] curry (( -- value )) define-declared ;
+
+: define-match-vars ( seq -- )
+ [ define-match-var ] each ;
+
+: MATCH-VARS: ! vars ...
+ ";" parse-tokens define-match-vars ; parsing
+
+: match-var? ( symbol -- bool )
+ dup word? [ "match-var" word-prop ] [ drop f ] if ;
+
+: set-match-var ( value var -- ? )
+ dup namespace key? [ get = ] [ set t ] if ;
+
+: (match) ( value1 value2 -- matched? )
+ {
+ { [ dup match-var? ] [ set-match-var ] }
+ { [ over match-var? ] [ swap set-match-var ] }
+ { [ 2dup = ] [ 2drop t ] }
+ { [ 2dup [ _ eq? ] either? ] [ 2drop t ] }
+ { [ 2dup [ sequence? ] both? ] [
+ 2dup [ length ] bi@ =
+ [ [ (match) ] 2all? ] [ 2drop f ] if ] }
+ { [ 2dup [ tuple? ] both? ]
+ [ [ tuple>array ] bi@ [ (match) ] 2all? ] }
+ { [ t ] [ 2drop f ] }
+ } cond ;
+
+: match ( value1 value2 -- bindings )
+ [ (match) ] H{ } make-assoc swap [ drop f ] unless ;
+
+MACRO: match-cond ( assoc -- )
+ <reversed>
+ [ "Fall-through in match-cond" throw ]
+ [
+ first2
+ >r [ dupd match ] curry r>
+ [ bind ] curry rot
+ [ ?if ] 2curry append
+ ] reduce ;
+
+: replace-patterns ( object -- result )
+ {
+ { [ dup number? ] [ ] }
+ { [ dup match-var? ] [ get ] }
+ { [ dup sequence? ] [ [ replace-patterns ] map ] }
+ { [ dup tuple? ] [ tuple>array replace-patterns >tuple ] }
+ [ ]
+ } cond ;
+
+: match-replace ( object pattern1 pattern2 -- result )
+ -rot
+ match [ "Pattern does not match" throw ] unless*
+ [ replace-patterns ] bind ;
+
+: ?1-tail ( seq -- tail/f )
+ dup length zero? not [ rest ] [ drop f ] if ;
+
+: (match-first) ( seq pattern-seq -- bindings leftover/f )
+ 2dup [ length ] bi@ < [ 2drop f f ]
+ [
+ 2dup length head over match
+ [ nip swap ?1-tail ] [ >r rest r> (match-first) ] if*
+ ] if ;
+
+: match-first ( seq pattern-seq -- bindings )
+ (match-first) drop ;
+
+: (match-all) ( seq pattern-seq -- )
+ tuck (match-first) swap
+ [
+ , [ swap (match-all) ] [ drop ] if*
+ ] [ 2drop ] if* ;
+
+: match-all ( seq pattern-seq -- bindings-seq )
+ [ (match-all) ] { } make ;
+
--- /dev/null
+ML-style pattern matching
--- /dev/null
+extensions
+++ /dev/null
-Slava Pestov
+++ /dev/null
-USING: help.markup help.syntax math ;
-IN: math.bitfields
-
-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"
- " } ;"
- }
-} ;
+++ /dev/null
-USING: accessors math math.bitfields tools.test kernel words ;
-IN: math.bitfields.tests
-
-[ 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
-
-[ 0 ] [ { } bitfield-quot call ] unit-test
-
-[ 256 ] [ 1 { 8 } bitfield-quot call ] unit-test
-
-[ 268 ] [ 3 1 { 8 2 } bitfield-quot call ] unit-test
-
-[ 268 ] [ 1 { 8 { 3 2 } } bitfield-quot call ] unit-test
-
-[ 512 ] [ 1 { { 1+ 8 } } bitfield-quot call ] unit-test
+++ /dev/null
-! Copyright (C) 2007, 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: arrays kernel math sequences words
-namespaces stack-checker.transforms ;
-IN: math.bitfields
-
-GENERIC: (bitfield) ( value accum shift -- newaccum )
-
-M: integer (bitfield) ( value accum shift -- newaccum )
- swapd shift bitor ;
-
-M: pair (bitfield) ( value accum pair -- newaccum )
- first2 >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
+++ /dev/null
-Domain-specific language for constructing integers
--- /dev/null
+Slava Pestov
+Doug Coleman
--- /dev/null
+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" }
+} ;
--- /dev/null
+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
--- /dev/null
+! 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
+<PRIVATE
+
+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 ;
+
+PRIVATE>
+
+MACRO: bitfield ( bitspec -- )
+ [ 0 ] [ (bitfield-quot) compose ] reduce ;
+
+! bit-count
+<PRIVATE
+
+DEFER: byte-bit-count
+
+<<
+
+\ byte-bit-count
+256 [
+ 0 swap [ [ 1+ ] when ] each-bit
+] B{ } map-as '[ HEX: ff bitand , nth-unsafe ] define-inline
+
+>>
+
+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
--- /dev/null
+Bitwise arithmetic utilities
: C{ \ } [ first2 rect> ] parse-literal ; parsing
M: complex pprint-delims drop \ C{ \ } ;
-
M: complex >pprint-sequence >rect 2array ;
+M: complex pprint* pprint-object ;
{ $syntax "<\" text \">" }
{ $description "This forms a multiline string literal ending in \">. Unlike the " { $link POSTPONE: STRING: } " form, you can end it in the middle of a line. This construct is non-nesting. In the example above, the string would be parsed as \"text\"." } ;
-{ POSTPONE: <" POSTPONE: STRING: } related-words
+HELP: /*
+{ $syntax "/* comment */" }
+{ $description "Provides C-like comments that can span multiple lines. One caveat is that " { $snippet "/*" } " and " { $snippet "*/" } " are still tokens and must not abut the comment text itself." }
+{ $example "USING: multiline ;"
+ "/* I think that I shall never see"
+ " A poem lovely as a tree. */"
+ ""
+} ;
-HELP: parse-here
-{ $values { "str" "a string" } }
-{ $description "Parses a multiline string literal, as used by " { $link POSTPONE: STRING: } "." } ;
+{ POSTPONE: <" POSTPONE: STRING: } related-words
HELP: parse-multiline-string
{ $values { "end-text" "a string delineating the end" } { "str" "the parsed string" } }
-{ $description "Parses a multiline string literal, as used by " { $link POSTPONE: <" } ". The end-text is the delimiter for the end." } ;
+{ $description "Parses the input stream until the " { $snippet "end-text" } " is reached and returns the parsed text as a string." }
+{ $notes "Used to implement " { $link POSTPONE: /* } " and " { $link POSTPONE: <" } "." } ;
+
+ARTICLE: "multiline" "Multiline"
+"Multiline strings:"
+{ $subsection POSTPONE: STRING: }
+{ $subsection POSTPONE: <" }
+"Multiline comments:"
+{ $subsection POSTPONE: /* }
+"Writing new multiline parsing words:"
+{ $subsection parse-multiline-string }
+;
-{ parse-here parse-multiline-string } related-words
+ABOUT: "multiline"
accessors ;
IN: multiline
+<PRIVATE
: next-line-text ( -- str )
lexer get dup next-line line-text>> ;
[ drop lexer get next-line ]
[ % "\n" % (parse-here) ] if
] [ ";" unexpected-eof ] if* ;
+PRIVATE>
: parse-here ( -- str )
[ (parse-here) ] "" make but-last
CREATE-WORD
parse-here 1quotation define-inline ; parsing
+<PRIVATE
: (parse-multiline-string) ( start-index end-text -- end-index )
lexer get line-text>> [
2dup start
lexer get next-line swap (parse-multiline-string)
] if*
] [ nip unexpected-eof ] if* ;
+PRIVATE>
: parse-multiline-string ( end-text -- str )
[
--- /dev/null
+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
--- /dev/null
+! 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
+++ /dev/null
-Joe Groff
\ No newline at end of file
+++ /dev/null
-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"
+++ /dev/null
-! 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) ;
+++ /dev/null
-Testing for OpenGL versions and extensions
\ No newline at end of file
+++ /dev/null
-opengl
-bindings
+++ /dev/null
-Joe Groff
\ No newline at end of file
+++ /dev/null
-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
-
+++ /dev/null
-Common support for OpenGL demos
\ No newline at end of file
+++ /dev/null
-Joe Groff
\ No newline at end of file
+++ /dev/null
-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
+++ /dev/null
-! 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 <uint> [ glGetFramebufferAttachmentParameterivEXT ] keep *uint ;
+++ /dev/null
-Rendering to offscreen textures using the GL_EXT_framebuffer_object extension
\ No newline at end of file
+++ /dev/null
-opengl
-bindings
+++ /dev/null
-IN: opengl.gadgets.tests
-USING: tools.test opengl.gadgets ;
-
-\ render* must-infer
+++ /dev/null
-! 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: <entry> cache-entry
-
-: make-entry ( gadget -- entry )
- dup render* <entry>
- [ 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 ;
+++ /dev/null
-Joe Groff
\ No newline at end of file
+++ /dev/null
-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 <gl-shader> } " - 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 <vertex-shader> } " - 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 <fragment-shader> } " - Compile GLSL code into a fragment shader object "}
- }
-} ;
-
-HELP: <gl-shader>
-{ $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: <vertex-shader>
-{ $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 <gl-shader>" } "." } ;
-
-HELP: <fragment-shader>
-{ $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 <gl-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 <gl-program> } ", " { $link <simple-gl-program> } " - 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: <gl-program>
-{ $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: <simple-gl-program>
-{ $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 <gl-program> } " 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." } ;
-
-{ <gl-program> <simple-gl-program> } 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"
+++ /dev/null
-! 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 [ <void*> swap call ] keep free ; inline
-
-: <gl-shader> ( 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 <int> [ glGetShaderiv ] keep *int ;
-
-: gl-shader-ok? ( shader -- ? )
- GL_COMPILE_STATUS gl-shader-get-int c-bool> ;
-
-: <vertex-shader> ( source -- vertex-shader )
- GL_VERTEX_SHADER <gl-shader> ; inline
-
-: (vertex-shader?) ( object -- ? )
- dup (gl-shader?)
- [ GL_SHADER_TYPE gl-shader-get-int GL_VERTEX_SHADER = ]
- [ drop f ] if ;
-
-: <fragment-shader> ( source -- fragment-shader )
- GL_FRAGMENT_SHADER <gl-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 <int> 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
-
-: <gl-program> ( 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 <int> [ 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 <int> 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" <c-array>
- 0 <int> 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?) ;
-
-: <simple-gl-program> ( vertex-shader-source fragment-shader-source -- program )
- >r <vertex-shader> check-gl-shader
- r> <fragment-shader> check-gl-shader
- 2array <gl-program> check-gl-program ;
-
+++ /dev/null
-OpenGL Shading Language (GLSL) support
\ No newline at end of file
+++ /dev/null
-opengl
-glsl
-bindings
\ No newline at end of file
! 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
! See http://factorcode.org/license.txt for BSD license.\r
USING: kernel compiler.units words arrays strings math.parser sequences \r
quotations vectors namespaces math assocs continuations peg\r
- peg.parsers unicode.categories multiline combinators.lib \r
+ peg.parsers unicode.categories multiline \r
splitting accessors effects sequences.deep peg.search\r
combinators.short-circuit lexer io.streams.string\r
stack-checker io prettyprint combinators parser ;\r
M: action-parser (compile) ( peg -- quot )
[ p1>> compile-parser 1quotation ] [ quot>> ] bi '[ @ , check-action ] ;
-: left-trim-slice ( string -- string )
- #! Return a new string without any leading whitespace
- #! from the original string.
- dup empty? [
- dup first blank? [ rest-slice left-trim-slice ] when
- ] unless ;
-
TUPLE: sp-parser p1 ;
M: sp-parser (compile) ( peg -- quot )
p1>> compile-parser 1quotation '[
- input-slice left-trim-slice input-from pos set @
+ input-slice [ blank? ] trim-left-slice input-from pos set @
] ;
TUPLE: delay-parser quot ;
--- /dev/null
+Chris Double
--- /dev/null
+! 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 } ;
+
--- /dev/null
+! 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
+
--- /dev/null
+! 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 ;
+
+
--- /dev/null
+Search and replace using parsing expression grammars
: PH{ \ } [ >persistent-hash ] parse-literal ; parsing
M: persistent-hash pprint-delims drop \ PH{ \ } ;
-
M: persistent-hash >pprint-sequence >alist ;
+M: persistent-hash pprint* pprint-object ;
! 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 ;
! 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
! 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 ;
! 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
: PV{ \ } [ >persistent-vector ] parse-literal ; parsing
M: persistent-vector pprint-delims drop \ PV{ \ } ;
-
M: persistent-vector >pprint-sequence ;
+M: persistent-vector pprint* pprint-object ;
INSTANCE: persistent-vector immutable-sequence
-USING: help.markup help.syntax io kernel prettyprint
+USING: help.markup help.syntax io kernel
prettyprint.config prettyprint.sections words strings ;
IN: prettyprint.backend
HELP: do-string-limit
{ $values { "str" string } { "trimmed" "a possibly trimmed string" } }
-{ $description "If " { $link string-limit } " is on, trims the string such that it does not exceed the margin, appending \"...\" if trimming took place." } ;
+{ $description "If " { $link string-limit? } " is on, trims the string such that it does not exceed the margin, appending \"...\" if trimming took place." } ;
HELP: pprint-string
{ $values { "obj" object } { "str" string } { "prefix" string } { "suffix" string } }
dup ch>ascii-escape [ "\\" % ] [ ] ?if , ;
: do-string-limit ( str -- trimmed )
- string-limit get [
+ string-limit? get [
dup length margin get > [
margin get 3 - head "..." append
] when
] if
] if ; inline
+: tuple>assoc ( tuple -- assoc )
+ [ class all-slots ] [ tuple-slots ] bi zip
+ [ [ initial>> ] dip = not ] assoc-filter
+ [ [ name>> ] dip ] assoc-map ;
+
+: pprint-slot-value ( name value -- )
+ <flow \ { pprint-word
+ [ text ] [ f <inset pprint* block> ] bi*
+ \ } pprint-word block> ;
+
+M: tuple pprint*
+ boa-tuples? get [ call-next-method ] [
+ [
+ <flow
+ \ T{ pprint-word
+ dup class pprint-word
+ t <inset
+ tuple>assoc [ pprint-slot-value ] assoc-each
+ block>
+ \ } pprint-word
+ block>
+ ] check-recursion
+ ] if ;
+
: do-length-limit ( seq -- trimmed n/f )
length-limit get dup [
over length over [-]
] check-recursion ;
M: object pprint* pprint-object ;
+M: vector pprint* pprint-object ;
+M: hashtable pprint* pprint-object ;
M: curry pprint*
dup quot>> callable? [ pprint-object ] [
-USING: help.markup help.syntax io kernel prettyprint
+USING: help.markup help.syntax io kernel
prettyprint.sections words ;
IN: prettyprint.config
HELP: line-limit
{ $var-description "The maximum number of lines output by the prettyprinter before output is truncated with \"...\". The default is " { $link f } ", denoting unlimited line count." } ;
-HELP: string-limit
+HELP: string-limit?
{ $var-description "Toggles whether printed strings are truncated to the margin." } ;
+
+HELP: boa-tuples?
+{ $var-description "Toggles whether tuples print in BOA-form or assoc-form." }
+{ $notes "See " { $link POSTPONE: T{ } " for a description of both literal tuple forms." } ;
-! Copyright (C) 2003, 2007 Slava Pestov.
+! Copyright (C) 2003, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-IN: prettyprint.config
USING: arrays generic assocs io kernel math
namespaces sequences strings io.styles vectors words
continuations ;
+IN: prettyprint.config
! Configuration
SYMBOL: tab-size
SYMBOL: nesting-limit
SYMBOL: length-limit
SYMBOL: line-limit
-SYMBOL: string-limit
+SYMBOL: string-limit?
+SYMBOL: boa-tuples?
-global [
- 4 tab-size set
- 64 margin set
- string-limit off
-] bind
+4 tab-size set-global
+64 margin set-global
{ $subsection nesting-limit }
{ $subsection length-limit }
{ $subsection line-limit }
-{ $subsection string-limit }
+{ $subsection string-limit? }
+{ $subsection boa-tuples? }
"Note that the " { $link short. } " and " { $link pprint-short } " variables override some of these variables."
{
$warning "Treat the global variables as essentially being constants. Only ever rebind them in a nested scope."
{ $subsection "prettyprint-section-protocol" } ;
ARTICLE: "prettyprint-literal" "Literal prettyprinting protocol"
-"Unless a more specialized method exists for the input class, the " { $link pprint* } " word outputs an object in a standard format, ultimately calling two generic words:"
+"Most custom data types have a literal syntax which resembles a sequence. An easy way to define such a syntax is to add a method to the " { $link pprint* } " generic word which calls " { $link pprint-object } ", and then to provide methods on two other generic words:"
{ $subsection pprint-delims }
{ $subsection >pprint-sequence }
"For example, consider the following data type, together with a parsing word for creating literals:"
{ $code "RECT[ 100 * 200 ]" }
"Without further effort, the literal does not print in the same way:"
{ $unchecked-example "RECT[ 100 * 200 ] ." "T{ rect f 100 200 }" }
-"However, we can define two methods easily enough:"
+"However, we can define three methods easily enough:"
{ $code
"M: rect pprint-delims drop \\ RECT[ \\ ] ;"
"M: rect >pprint-sequence dup rect-w \\ * rot rect-h 3array ;"
+ "M: rect pprint* pprint-object ;"
}
"Now, it will be printed in a custom way:"
{ $unchecked-example "RECT[ 100 * 200 ] ." "RECT[ 100 * 200 ]" } ;
{ line-limit 1 }
{ length-limit 15 }
{ nesting-limit 2 }
- { string-limit t }
+ { string-limit? t }
+ { boa-tuples? t }
} clone [ pprint ] bind ;
: unparse-short ( obj -- str )
! 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
-USING: random sequences tools.test ;
+USING: random sequences tools.test kernel ;
IN: random.tests
[ 4 ] [ 4 random-bytes length ] unit-test
[ 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
] keep nth
] if ;
+: delete-random ( seq -- elt )
+ [ length random ] keep [ nth ] 2keep delete-nth ;
+
: random-bits ( n -- r ) 2^ random ;
: with-random ( tuple quot -- )
! 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
} cond ;
: multiline? ( response -- boolean )
- ?fourth CHAR: - = ;
+ 3 swap ?nth CHAR: - = ;
: process-multiline ( multiline -- response )
>r readln r> 2dup " " append head? [
: 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 ;
: infer-shuffle ( shuffle -- )
[ in>> length consume-d ] keep ! inputs shuffle
- [ drop ] [ shuffle* dup copy-values dup output-d ] 2bi ! inputs outputs copies
+ [ drop ] [ shuffle dup copy-values dup output-d ] 2bi ! inputs outputs copies
[ nip ] [ swap zip ] 2bi ! inputs copies mapping
#shuffle, ;
! See http://factorcode.org/license.txt for BSD license.\r
USING: io io.streams.string kernel math namespaces sequences\r
strings circular prettyprint debugger ascii sbufs fry summary\r
-accessors sequences.lib ;\r
+accessors ;\r
IN: state-parser\r
\r
! * Basic underlying words\r
\r
: take ( n -- string )\r
[ 1- ] [ <sbuf> ] bi [\r
- '[ drop get-char [ next , push f ] [ t ] if* ] attempt-each drop\r
+ '[ drop get-char [ next , push f ] [ t ] if* ] contains? drop\r
] keep get-char [ over push ] when* >string ;\r
\r
: pass-blank ( -- )\r
f
}
}
-} ] [ "resource:extra/syndication/test/rss1.xml" load-news-file ] unit-test
+} ] [ "resource:basis/syndication/test/rss1.xml" load-news-file ] unit-test
[ T{
feed
f
T{ timestamp f 2003 12 13 8 29 29 T{ duration f 0 0 0 -4 0 0 } }
}
}
-} ] [ "resource:extra/syndication/test/atom.xml" load-news-file ] unit-test
+} ] [ "resource:basis/syndication/test/atom.xml" load-news-file ] unit-test
-USING: help.markup help.syntax words parser ;
+USING: help.markup help.syntax words parser quotations strings
+system sequences ;
IN: tools.annotations
ARTICLE: "tools.annotations" "Word annotations"
{ $values { "word" word } }
{ $description "Annotates a word definition to print the data stack on entry and exit." } ;
+{ watch watch-vars reset } related-words
+
HELP: breakpoint
{ $values { "word" word } }
{ $description "Annotates a word definition to enter the single stepper when executed." } ;
HELP: breakpoint-if
{ $values { "quot" "a quotation with stack effect" { $snippet "( -- ? )" } } { "word" word } }
{ $description "Annotates a word definition to enter the single stepper if the quotation yields true." } ;
+
+HELP: annotate-methods
+{ $values
+ { "word" word } { "quot" quotation } }
+{ $description "Annotates the word -- for generic words, all its methods -- with the quotation." } ;
+
+HELP: entering
+{ $values
+ { "str" string } }
+{ $description "Prints a message and the inputs to the word before the word has been called." } ;
+
+HELP: leaving
+{ $values
+ { "str" string } }
+{ $description "Prints a message and the outputs from a word after a word has been called." } ;
+
+HELP: reset
+{ $values
+ { "word" word } }
+{ $description "Resets any annotations on a word." }
+{ $notes "This word will remove a " { $link watch } "." } ;
+
+HELP: watch-vars
+{ $values
+ { "word" word } { "vars" "a sequence of symbols" } }
+{ $description "Annotates a word definition to print the " { $snippet "vars" } " upon entering the word. This word is useful for debugging." } ;
+
+HELP: word-inputs
+{ $values
+ { "word" word }
+ { "seq" sequence } }
+{ $description "Makes a sequence of the inputs to a word by counting the number of inputs in the stack effect and saving that many items from the datastack." } ;
+
[\r
<dispatcher>\r
add-quot-responder\r
- "resource:extra/http/test" <static> >>default\r
+ "resource:basis/http/test" <static> >>default\r
main-responder set\r
\r
test-httpd\r
strip-prettyprint? [
{
prettyprint.config:margin
- prettyprint.config:string-limit
+ prettyprint.config:string-limit?
+ prettyprint.config:boa-tuples?
prettyprint.config:tab-size
} %
] when
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 math alien ;
IN: tools.scaffold
SYMBOL: developer-name
{ "obj3" object } { "obj4" object }
{ "quot" quotation } { "quot1" quotation }
{ "quot2" quotation } { "quot3" quotation }
+ { "quot'" quotation }
{ "string" string } { "string1" string }
{ "string2" string } { "string3" string }
{ "str" string }
{ "ch" "a character" }
{ "word" word }
{ "array" array }
+ { "duration" duration }
{ "path" "a pathname string" }
{ "vocab" "a vocabulary specifier" }
{ "vocab-root" "a vocabulary root string" }
+ { "c-ptr" c-ptr }
+ { "seq" sequence } { "seq1" sequence } { "seq2" sequence }
+ { "seq3" sequence } { "seq4" sequence }
+ { "seq1'" sequence } { "seq2'" sequence }
+ { "newseq" sequence }
+ { "assoc" assoc } { "assoc1" assoc } { "assoc2" assoc }
+ { "assoc3" assoc } { "newassoc" assoc }
+ { "alist" "an array of key/value pairs" }
+ { "keys" sequence } { "values" sequence }
+ { "class" class }
} at* ;
: add-using ( object -- )
: 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 ;
[ drop scaffold-authors ]
[ nip require ]
} 2cleave ;
+
+SYMBOL: examples-flag
+
+: example ( -- )
+ {
+ "{ $example \"\" \"USING: prettyprint ;\""
+ " \"\""
+ " \"\""
+ "}"
+ } [ examples-flag get [ " " write ] when print ] each ;
+
+: examples ( n -- )
+ t \ examples-flag [
+ "{ $examples " print
+ [ example ] times
+ "}" print
+ ] with-variable ;
TR: convert-separators "/\\" ".." ;\r
\r
: vocab-dir>vocab-name ( path -- vocab )\r
- left-trim-separators\r
- right-trim-separators\r
+ trim-left-separators\r
+ trim-right-separators\r
convert-separators ;\r
\r
: path>vocab-name ( path -- vocab )\r
! 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
+++ /dev/null
-
-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 ) 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* ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
+++ /dev/null
-
-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]" <c-array>
- >>pixels ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: new-frame-buffer ( class -- gadget )
- new-gadget
- [ ] >>action
- { 100 100 } >>pdim
- [ ] >>graft
- [ ] >>ungraft ;
-
-: <frame-buffer> ( -- 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 * <sliced-groups> ] 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 ;
-
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-
-USING: kernel assocs ui.gestures ui.gadgets.wrappers accessors ;
-
-IN: ui.gadgets.handler
-
-TUPLE: handler < wrapper table ;
-
-: <handler> ( 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
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-
-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 ;
+++ /dev/null
-
-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 ) 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 <range> ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-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
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-
-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 ;
-
-: <slate> ( 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 ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+++ /dev/null
-William Schlieper
\ No newline at end of file
+++ /dev/null
-Tabbed windows
\ No newline at end of file
+++ /dev/null
-! Copyright (C) 2008 William Schlieper\r
-! See http://factorcode.org/license.txt for BSD license.\r
-\r
-USING: accessors kernel fry math math.vectors sequences arrays vectors assocs\r
- hashtables models models.range models.compose combinators\r
- ui ui.gadgets ui.gadgets.buttons ui.gadgets.frames ui.gadgets.packs\r
- ui.gadgets.grids ui.gadgets.viewports ui.gadgets.books locals ;\r
-\r
-IN: ui.gadgets.tabs\r
-\r
-TUPLE: tabbed < frame names toggler content ;\r
-\r
-DEFER: (del-page)\r
-\r
-:: add-toggle ( model n name toggler -- )\r
- <frame>\r
- n name toggler parent>> '[ , , , (del-page) ] "X" swap <bevel-button>\r
- @right grid-add\r
- n model name <toggle-button> @center grid-add\r
- toggler swap add-gadget drop ;\r
-\r
-: redo-toggler ( tabbed -- )\r
- [ names>> ] [ model>> ] [ toggler>> ] tri\r
- [ clear-gadget ] keep\r
- [ [ length ] keep ] 2dip\r
- '[ , _ _ , add-toggle ] 2each ;\r
-\r
-: refresh-book ( tabbed -- )\r
- model>> [ ] change-model ;\r
-\r
-: (del-page) ( n name tabbed -- )\r
- { [ [ remove ] change-names redo-toggler ]\r
- [ dupd [ names>> length ] [ model>> ] bi\r
- [ [ = ] keep swap [ 1- ] when\r
- [ < ] keep swap [ 1- ] when ] change-model ]\r
- [ content>> nth-gadget unparent ]\r
- [ refresh-book ]\r
- } cleave ;\r
-\r
-: add-page ( page name tabbed -- )\r
- [ names>> push ] 2keep\r
- [ [ model>> swap ]\r
- [ names>> length 1 - swap ]\r
- [ toggler>> ] tri add-toggle ]\r
- [ content>> swap add-gadget drop ]\r
- [ refresh-book ] tri ;\r
-\r
-: del-page ( name tabbed -- )\r
- [ names>> index ] 2keep (del-page) ;\r
-\r
-: new-tabbed ( assoc class -- tabbed )\r
- new-frame\r
- 0 <model> >>model\r
- <pile> 1 >>fill >>toggler\r
- dup toggler>> @left grid-add\r
- swap\r
- [ keys >vector >>names ]\r
- [ values over model>> <book> >>content dup content>> @center grid-add ]\r
- bi\r
- dup redo-toggler ;\r
- \r
-: <tabbed> ( assoc -- tabbed ) tabbed new-tabbed ;\r
+++ /dev/null
-
-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 ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: <tiling> ( -- 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 ;
-
-: <tiling-shelf> ( -- gadget )
- tiling-shelf new init-tiling { 1 0 } >>orientation ;
-
-: <tiling-pile> ( -- 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
: 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>
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
: insensitive= ( str1 str2 levels-removed -- ? )\r
[\r
swap collation-key swap\r
- [ [ 0 = not ] right-trim but-last ] times\r
+ [ [ 0 = not ] trim-right but-last ] times\r
] curry bi@ = ;\r
PRIVATE>\r
\r
+++ /dev/null
-Doug Coleman
+++ /dev/null
-Doug Coleman
+++ /dev/null
-! 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 } <dimensioned> ;
-
+++ /dev/null
-
- 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
+++ /dev/null
-Doug Coleman
+++ /dev/null
-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
-
+++ /dev/null
-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..
+++ /dev/null
-Doug Coleman
+++ /dev/null
-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
+++ /dev/null
-USING: kernel math math.constants sequences units ;
-IN: units.si
-
-! SI Conversions
-! http://physics.nist.gov/cuu/Units/
-
-! Length
-: m ( n -- dimensioned ) { m } { } <dimensioned> ;
-
-! Mass
-: kg ( n -- dimensioned ) { kg } { } <dimensioned> ;
-
-! Time
-: s ( n -- dimensioned ) { s } { } <dimensioned> ;
-
-! Electric current
-: A ( n -- dimensioned ) { A } { } <dimensioned> ;
-
-! Temperature
-: K ( n -- dimensioned ) { K } { } <dimensioned> ;
-
-! Amount of substance
-: mol ( n -- dimensioned ) { mol } { } <dimensioned> ;
-
-! Luminous intensity
-: cd ( n -- dimensioned ) { cd } { } <dimensioned> ;
-
-! SI derived units
-: m^2 ( n -- dimensioned ) { m m } { } <dimensioned> ;
-: m^3 ( n -- dimensioned ) { m m m } { } <dimensioned> ;
-: m/s ( n -- dimensioned ) { m } { s } <dimensioned> ;
-: m/s^2 ( n -- dimensioned ) { m } { s s } <dimensioned> ;
-: 1/m ( n -- dimensioned ) { } { m } <dimensioned> ;
-: kg/m^3 ( n -- dimensioned ) { kg } { m m m } <dimensioned> ;
-: A/m^2 ( n -- dimensioned ) { A } { m m } <dimensioned> ;
-: A/m ( n -- dimensioned ) { A } { m } <dimensioned> ;
-: mol/m^3 ( n -- dimensioned ) { mol } { m m m } <dimensioned> ;
-: cd/m^2 ( n -- dimensioned ) { cd } { m m } <dimensioned> ;
-: kg/kg ( n -- dimensioned ) { kg } { kg } <dimensioned> ;
-
-! 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 } <dimensioned> ;
-: N ( n -- newton ) { kg m } { s s } <dimensioned> ;
-: Pa ( n -- pascal ) { kg } { m s s } <dimensioned> ;
-: J ( n -- joule ) { m m kg } { s s } <dimensioned> ;
-: W ( n -- watt ) { m m kg } { s s s } <dimensioned> ;
-: C ( n -- coulomb ) { s A } { } <dimensioned> ;
-: V ( n -- volt ) { m m kg } { s s s A } <dimensioned> ;
-: F ( n -- farad ) { s s s s A A } { m m kg } <dimensioned> ;
-: ohm ( n -- ohm ) { m m kg } { s s s A A } <dimensioned> ;
-: S ( n -- siemens ) { s s s A A } { m m kg } <dimensioned> ;
-: Wb ( n -- weber ) { m m kg } { s s A } <dimensioned> ;
-: T ( n -- tesla ) { kg } { s s A } <dimensioned> ;
-: H ( n -- henry ) { m m kg } { s s A A } <dimensioned> ;
-: deg-C ( n -- Celsius ) 27315/100 + { K } { } <dimensioned> ;
-: lm ( n -- lumen ) { m m cd } { m m } <dimensioned> ;
-: lx ( n -- lux ) { m m cd } { m m m m } <dimensioned> ;
-: Bq ( n -- becquerel ) { } { s } <dimensioned> ;
-: Gy ( n -- gray ) { m m } { s s } <dimensioned> ;
-: Sv ( n -- sievert ) { m m } { s s } <dimensioned> ;
-: kat ( n -- katal ) { mol } { s } <dimensioned> ;
-
-! 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 ) { } { } <dimensioned> ;
-: 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 } <dimensioned> ;
-: 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 ;
+++ /dev/null
-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 { } { } <dimensioned> = ] 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 } <dimensioned> = ] unit-test
-
-: km/L km 1 L d/ ;
-: mpg miles 1 gallons d/ ;
-
-[ t ] [ 100 10 / km/L [ mpg ] undo 23 1 ~ ] unit-test
+++ /dev/null
-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 ;
-
-: <dimensioned> ( n top bot -- obj )
- symbolic-reduce
- [ natural-sort ] bi@
- dimensioned boa ;
-
-: >dimensioned< ( d -- n top bot )
- [ value>> ] [ top>> ] [ bot>> ] tri ;
-
-\ <dimensioned> [ >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@ ;
-
-: <dimension-op ( dim dim -- top bot val val )
- 2dup check-dimensions dup dimensions 2swap 2values ;
-
-: dimension-op> ( top bot val -- dim )
- -rot <dimensioned> ;
-
-: d+ ( d d -- d ) <dimension-op + dimension-op> ;
-
-: d- ( d d -- d ) <dimension-op - dimension-op> ;
-
-: scalar ( n -- d )
- { } { } <dimensioned> ;
-
-: 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
! Copyright (C) 2008 Slava Pestov.\r
! See http://factorcode.org/license.txt for BSD license.\r
-USING: alien.syntax math math.bitfields ;\r
+USING: alien.syntax math math.bitwise ;\r
IN: unix.linux.inotify\r
\r
C-STRUCT: inotify-event\r
IN: urls.tests
USING: urls urls.private tools.test
-tuple-syntax arrays kernel assocs
-present accessors ;
+arrays kernel assocs present accessors ;
[ "hello%20world" ] [ "hello world" url-encode ] unit-test
[ "hello world" ] [ "hello%20world" url-decode ] unit-test
: urls
{
{
- TUPLE{ url
- protocol: "http"
- host: "www.apple.com"
- port: 1234
- path: "/a/path"
- query: H{ { "a" "b" } }
- anchor: "foo"
+ T{ url
+ { protocol "http" }
+ { host "www.apple.com" }
+ { port 1234 }
+ { path "/a/path" }
+ { query H{ { "a" "b" } } }
+ { anchor "foo" }
}
"http://www.apple.com:1234/a/path?a=b#foo"
}
{
- TUPLE{ url
- protocol: "http"
- host: "www.apple.com"
- path: "/a/path"
- query: H{ { "a" "b" } }
- anchor: "foo"
+ T{ url
+ { protocol "http" }
+ { host "www.apple.com" }
+ { path "/a/path" }
+ { query H{ { "a" "b" } } }
+ { anchor "foo" }
}
"http://www.apple.com/a/path?a=b#foo"
}
{
- TUPLE{ url
- protocol: "http"
- host: "www.apple.com"
- port: 1234
- path: "/another/fine/path"
- anchor: "foo"
+ T{ url
+ { protocol "http" }
+ { host "www.apple.com" }
+ { port 1234 }
+ { path "/another/fine/path" }
+ { anchor "foo" }
}
"http://www.apple.com:1234/another/fine/path#foo"
}
{
- TUPLE{ url
- path: "/a/relative/path"
- anchor: "foo"
+ T{ url
+ { path "/a/relative/path" }
+ { anchor "foo" }
}
"/a/relative/path#foo"
}
{
- TUPLE{ url
- path: "/a/relative/path"
+ T{ url
+ { path "/a/relative/path" }
}
"/a/relative/path"
}
{
- TUPLE{ url
- path: "a/relative/path"
+ T{ url
+ { path "a/relative/path" }
}
"a/relative/path"
}
{
- TUPLE{ url
- path: "bar"
- query: H{ { "a" "b" } }
+ T{ url
+ { path "bar" }
+ { query H{ { "a" "b" } } }
}
"bar?a=b"
}
{
- TUPLE{ url
- protocol: "ftp"
- host: "ftp.kernel.org"
- username: "slava"
- path: "/"
+ T{ url
+ { protocol "ftp" }
+ { host "ftp.kernel.org" }
+ { username "slava" }
+ { path "/" }
}
"ftp://slava@ftp.kernel.org/"
}
{
- TUPLE{ url
- protocol: "ftp"
- host: "ftp.kernel.org"
- username: "slava"
- password: "secret"
- path: "/"
+ T{ url
+ { protocol "ftp" }
+ { host "ftp.kernel.org" }
+ { username "slava" }
+ { password "secret" }
+ { path "/" }
}
"ftp://slava:secret@ftp.kernel.org/"
}
[ "/xxx/bar" ] [ "/xxx/baz" "bar" url-append-path ] unit-test
[
- TUPLE{ url
- protocol: "http"
- host: "www.apple.com"
- port: 1234
- path: "/a/path"
+ T{ url
+ { protocol "http" }
+ { host "www.apple.com" }
+ { port 1234 }
+ { path "/a/path" }
}
] [
- TUPLE{ url
- protocol: "http"
- host: "www.apple.com"
- port: 1234
- path: "/foo"
+ T{ url
+ { protocol "http" }
+ { host "www.apple.com" }
+ { port 1234 }
+ { path "/foo" }
}
- TUPLE{ url
- path: "/a/path"
+ T{ url
+ { path "/a/path" }
}
derive-url
] unit-test
[
- TUPLE{ url
- protocol: "http"
- host: "www.apple.com"
- port: 1234
- path: "/a/path/relative/path"
- query: H{ { "a" "b" } }
- anchor: "foo"
+ T{ url
+ { protocol "http" }
+ { host "www.apple.com" }
+ { port 1234 }
+ { path "/a/path/relative/path" }
+ { query H{ { "a" "b" } } }
+ { anchor "foo" }
}
] [
- TUPLE{ url
- protocol: "http"
- host: "www.apple.com"
- port: 1234
- path: "/a/path/"
+ T{ url
+ { protocol "http" }
+ { host "www.apple.com" }
+ { port 1234 }
+ { path "/a/path/" }
}
- TUPLE{ url
- path: "relative/path"
- query: H{ { "a" "b" } }
- anchor: "foo"
+ T{ url
+ { path "relative/path" }
+ { query H{ { "a" "b" } } }
+ { anchor "foo" }
}
derive-url
] unit-test
[
- TUPLE{ url
- protocol: "http"
- host: "www.apple.com"
- port: 1234
- path: "/a/path/relative/path"
- query: H{ { "a" "b" } }
- anchor: "foo"
+ T{ url
+ { protocol "http" }
+ { host "www.apple.com" }
+ { port 1234 }
+ { path "/a/path/relative/path" }
+ { query H{ { "a" "b" } } }
+ { anchor "foo" }
}
] [
- TUPLE{ url
- protocol: "http"
- host: "www.apple.com"
- port: 1234
- path: "/a/path/"
+ T{ url
+ { protocol "http" }
+ { host "www.apple.com" }
+ { port 1234 }
+ { path "/a/path/" }
}
- TUPLE{ url
- path: "relative/path"
- query: H{ { "a" "b" } }
- anchor: "foo"
+ T{ url
+ { path "relative/path" }
+ { query H{ { "a" "b" } } }
+ { anchor "foo" }
}
derive-url
] unit-test
[
- TUPLE{ url
- protocol: "http"
- host: "www.apple.com"
- path: "/xxx/baz"
+ T{ url
+ { protocol "http" }
+ { host "www.apple.com" }
+ { path "/xxx/baz" }
}
] [
- TUPLE{ url
- protocol: "http"
- host: "www.apple.com"
- path: "/xxx/bar"
+ T{ url
+ { protocol "http" }
+ { host "www.apple.com" }
+ { path "/xxx/bar" }
}
- TUPLE{ url
- path: "baz"
+ T{ url
+ { path "baz" }
}
derive-url
! 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 ;
-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
! 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
! 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
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
! 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 )
! 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
! 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 -- ) <comment> , ;
(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 <name> ] [ <simple-name> ] 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 <xml> ;
-
-DEFER: XML>
-
-: <XML
- \ XML> [ >quotation ] parse-literal
- { } parsed \ make parsed \ >xml-document parsed ; parsing
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 ;
HELP: dll
{ $class-description "The class of native library handles. See " { $link "syntax-aliens" } " for syntax and " { $link "dll.private" } " for general information." } ;
+HELP: dll-valid? ( dll -- ? )
+{ $values { "dll" dll } { "?" "a boolean" } }
+{ $description "Returns true if the library exists and is loaded." } ;
+
HELP: expired?
-{ $values { "c-ptr" "an alien, byte array, or " { $link f } } { "?" "a boolean" } }
+{ $values { "c-ptr" c-ptr } { "?" "a boolean" } }
{ $description "Tests if the alien is a relic from an earlier session. A byte array is never considered to have expired, whereas passing " { $link f } " always yields true." } ;
+HELP: <bad-alien>
+{ $values { "alien" c-ptr } }
+{ $description "Constructs an invalid alien pointer that has expired." } ;
+
+HELP: <library>
+{ $values
+ { "path" "a pathname string" } { "abi" "the ABI used by the library, either " { $snippet "cdecl" } " or " { $snippet "stdcall" } }
+ { "library" library } }
+{ $description "Opens a C library using the path and ABI parameters and outputs a library tuple." }
+{ $notes "User code should use " { $link add-library } " so that the opened library is added to a global hashtable, " { $link libraries } "." } ;
+
+HELP: libraries
+{ $description "A global hashtable that keeps a list of open libraries. Use the " { $link add-library } " word to construct a library and add it with a single call." } ;
+
HELP: <displaced-alien> ( displacement c-ptr -- alien )
-{ $values { "displacement" "an integer" } { "c-ptr" "an alien, byte array, or " { $link f } } { "alien" "a new alien" } }
+{ $values { "displacement" "an integer" } { "c-ptr" c-ptr } { "alien" "a new alien" } }
{ $description "Creates a new alien address object, wrapping a raw memory address. The alien points to a location in memory which is offset by " { $snippet "displacement" } " from the address of " { $snippet "c-ptr" } "." }
{ $notes "Passing a value of " { $link f } " for " { $snippet "c-ptr" } " creates an alien with an absolute address; this is how " { $link <alien> } " is implemented."
$nl
{ <alien> <displaced-alien> alien-address } related-words
HELP: alien-address ( c-ptr -- addr )
-{ $values { "c-ptr" "an alien or " { $link f } } { "addr" "a non-negative integer" } }
+{ $values { "c-ptr" c-ptr } { "addr" "a non-negative integer" } }
{ $description "Outputs the address of an alien." }
{ $notes "Taking the address of a " { $link byte-array } " is explicitly prohibited since byte arrays can be moved by the garbage collector between the time the address is taken, and when it is accessed. If you need to pass pointers to C functions which will persist across alien calls, you must allocate unmanaged memory instead. See " { $link "malloc" } "." } ;
} ;
HELP: alien-callback
-{ $values { "return" "a C return type" } { "parameters" "a sequence of C parameter types" } { "abi" "one of " { $snippet "\"cdecl\"" } " or " { $snippet "\"stdcall\"" } } { "quot" "a quotation" } { "alien" c-ptr } }
+{ $values { "return" "a C return type" } { "parameters" "a sequence of C parameter types" } { "abi" "one of " { $snippet "\"cdecl\"" } " or " { $snippet "\"stdcall\"" } } { "quot" "a quotation" } { "alien" alien } }
{ $description
"Defines a callback from C to Factor which accepts the given set of parameters from the C caller, pushes them on the data stack, calls the quotation, and passes a return value back to the C caller. A return type of " { $snippet "\"void\"" } " indicates that no value is to be returned."
$nl
"Usually one never has to deal with DLL handles directly; the C library interface creates them as required. However if direct access to these operating system facilities is required, the following primitives can be used:"
{ $subsection dlopen }
{ $subsection dlsym }
-{ $subsection dlclose } ;
+{ $subsection dlclose }
+{ $subsection dll-valid? } ;
ARTICLE: "embedding-api" "Factor embedding API"
"The Factor embedding API is defined in " { $snippet "vm/master.h" } "."
-! Copyright (C) 2007 Daniel Ehrenberg and Slava Pestov
+! Copyright (C) 2007 Daniel Ehrenberg, Slava Pestov, and Doug Coleman
! See http://factorcode.org/license.txt for BSD license.
USING: help.markup help.syntax kernel sequences
-sequences.private namespaces math ;
+sequences.private namespaces math quotations ;
IN: assocs
ARTICLE: "alists" "Association lists"
{ $subsection remove-all }
{ $subsection substitute }
{ $subsection substitute-here }
+{ $subsection extract-keys }
{ $see-also key? assoc-contains? assoc-all? "sets" } ;
ARTICLE: "assocs-mutation" "Storing keys and values in assocs"
{ $subsection rename-at }
{ $subsection change-at }
{ $subsection at+ }
-{ $see-also set-at delete-at clear-assoc } ;
+{ $see-also set-at delete-at clear-assoc push-at } ;
+
+ARTICLE: "assocs-conversions" "Associative mapping conversions"
+"Converting to other assocs:"
+{ $subsection assoc-clone-like }
+"Combining a sequence of assocs into a single assoc:"
+{ $subsection assoc-combine }
+"Creating an assoc from key/value sequences:"
+{ $subsection zip }
+"Creating key/value sequences from an assoc:"
+{ $subsection unzip }
+;
ARTICLE: "assocs-combinators" "Associative mapping combinators"
"The following combinators can be used on any associative mapping."
{ $subsection assoc-filter }
{ $subsection assoc-contains? }
{ $subsection assoc-all? }
-"Three additional combinators:"
+"Additional combinators:"
{ $subsection cache }
{ $subsection map>assoc }
-{ $subsection assoc>map } ;
+{ $subsection assoc>map }
+{ $subsection assoc-map-as }
+{ $subsection search-alist }
+"Utility word:"
+{ $subsection assoc-pusher } ;
ARTICLE: "assocs" "Associative mapping operations"
"An " { $emphasis "associative mapping" } ", abbreviated " { $emphasis "assoc" } ", is a collection of key/value pairs which provides efficient lookup and storage indexed by key."
{ $subsection "assocs-values" }
{ $subsection "assocs-mutation" }
{ $subsection "assocs-combinators" }
-{ $subsection "assocs-sets" } ;
+{ $subsection "assocs-sets" }
+{ $subsection "assocs-conversions" } ;
ABOUT: "assocs"
}
} ;
+{ assoc-map assoc-map-as } related-words
+
HELP: assoc-push-if
{ $values { "accum" "a resizable mutable sequence" } { "quot" "a quotation with stack effect " { $snippet "( key value -- ? )" } } { "key" object } { "value" object } }
{ $description "If the quotation yields true when applied to the key/value pair, adds the key/value pair at the end of " { $snippet "accum" } "." } ;
{ $values { "assoc" assoc } { "newassoc" "an array of key/value pairs" } }
{ $contract "Converts an associative structure into an association list." }
{ $notes "The " { $link assoc } " mixin has a default implementation for this generic word which constructs the association list by iterating over the assoc with " { $link assoc-find } "." } ;
+
+HELP: assoc-clone-like
+{ $values
+ { "assoc" assoc } { "exemplar" assoc }
+ { "newassoc" assoc } }
+{ $description "Outputs a newly-allocated assoc with the same elements as " { $snippet "assoc" } "." }
+{ $examples { $example "USING: prettyprint assocs hashtables ;" "H{ { 1 2 } { 3 4 } } { } assoc-clone-like ." "{ { 1 2 } { 3 4 } }" } } ;
+
+HELP: assoc-combine
+{ $values
+ { "seq" "a sequence of assocs" }
+ { "union" assoc } }
+{ $description "Takes the union of all of the " { $snippet "assocs" } " in " { $snippet "seq" } "." }
+{ $examples { $example "USING: prettyprint assocs ;" "{ H{ { 1 2 } } H{ { 3 4 } } } assoc-combine ." "H{ { 1 2 } { 3 4 } }" } } ;
+
+HELP: assoc-map-as
+{ $values
+ { "assoc" assoc } { "quot" quotation } { "exemplar" assoc }
+ { "newassoc" assoc } }
+{ $description "Applies the quotation to each entry in the input assoc and collects the results in a new assoc of the stame type as the exemplar." }
+{ $examples { $example "USING: prettyprint assocs hashtables math ;" " H{ { 1 2 } { 3 4 } } [ sq ] { } assoc-map-as ." "{ { 1 4 } { 3 16 } }" } } ;
+
+HELP: assoc-pusher
+{ $values
+ { "quot" "a predicate quotation" }
+ { "quot'" quotation } { "accum" assoc } }
+{ $description "Creates a new " { $snippet "assoc" } " to accumulate the key/value pairs which return true for a predicate. Returns a new quotation which accepts a pair of object to be tested and stored in the accumulator if the test yields true. The accumulator is left on the stack for convenience." }
+{ $example "! Find only the pairs that sum to 5:" "USING: prettyprint assocs math kernel ;"
+ "{ { 1 2 } { 2 3 } { 3 4 } } [ + 5 = ] assoc-pusher [ assoc-each ] dip ."
+ "V{ { 2 3 } }"
+}
+{ $notes "Used to implement the " { $link assoc-filter } " word." } ;
+
+
+HELP: extract-keys
+{ $values
+ { "seq" sequence } { "assoc" assoc }
+ { "subassoc" assoc } }
+{ $description "Outputs an new " { $snippet "assoc" } " with key/value pairs whose keys match the elements in the input " { $snippet "seq" } "." }
+{ $examples
+ { $example "USING: prettyprint assocs ;"
+ "{ 1 3 } { { 1 10 } { 2 20 } { 3 30 } } extract-keys ."
+ "{ { 1 10 } { 3 30 } }"
+ }
+} ;
+
+HELP: push-at
+{ $values
+ { "value" object } { "key" object } { "assoc" assoc } }
+{ $description "Pushes the " { $snippet "value" } " onto a " { $snippet "vector" } " stored at the " { $snippet "key" } " in the " { $snippet "assoc" } ". If the " { $snippet "key" } " does not yet exist, creates a new " { $snippet "vector" } " at that " { $snippet "key" } " and pushes the " { $snippet "value" } "." }
+{ $examples { $example "USING: prettyprint assocs kernel ;"
+"H{ { \"cats\" V{ \"Mittens\" } } } \"Mew\" \"cats\" pick push-at ."
+"H{ { \"cats\" V{ \"Mittens\" \"Mew\" } } }"
+} } ;
+
+HELP: search-alist
+{ $values
+ { "key" object } { "alist" "an array of key/value pairs" }
+ { "pair/f" "a key/value pair" } { "i/f" integer } }
+{ $description "Performs an in-order traversal of a " { $snippet "alist" } " and stops when the key is matched or the end of the " { $snippet "alist" } " has been reached. If there is no match, both outputs are " { $link f } "." }
+{ $examples { $example "USING: prettyprint assocs kernel ;"
+ "3 { { 1 2 } { 3 4 } } search-alist [ . ] bi@"
+ "{ 3 4 }\n1"
+ } { $example "USING: prettyprint assocs kernel ;"
+ "6 { { 1 2 } { 3 4 } } search-alist [ . ] bi@"
+ "f\nf"
+ }
+} ;
+
+HELP: unzip
+{ $values
+ { "assoc" assoc }
+ { "keys" sequence } { "values" sequence } }
+{ $description "Outputs an array of keys and an array of values of the input " { $snippet "assoc" } "." }
+{ $examples
+ { $example "USING: prettyprint assocs kernel ;"
+ "{ { 1 4 } { 2 5 } { 3 6 } } unzip [ . ] bi@"
+ "{ 1 2 3 }\n{ 4 5 6 }"
+ }
+} ;
+
+HELP: zip
+{ $values
+ { "keys" sequence } { "values" sequence }
+ { "alist" "an array of key/value pairs" } }
+{ $description "Combines two sequences pairwise into a single sequence of key/value pairs." }
+{ $examples
+ { $example "" "USING: prettyprint assocs ;"
+ "{ 1 2 3 } { 4 5 6 } zip ."
+ "{ { 1 4 } { 2 5 } { 3 6 } }"
+ }
+} ;
+{ unzip zip } related-words
: unzip ( assoc -- keys values )
dup assoc-empty? [ drop { } { } ] [ >alist flip first2 ] if ;
-: search-alist ( key alist -- pair i )
+: search-alist ( key alist -- pair/f i/f )
[ first = ] with find swap ; inline
M: sequence at*
-USING: help.markup help.syntax ;
+USING: kernel help.markup help.syntax ;
IN: byte-arrays
ARTICLE: "byte-arrays" "Byte arrays"
{ $subsection byte-array? }
"There are several ways to construct byte arrays."
{ $subsection >byte-array }
-{ $subsection <byte-array> } ;
+{ $subsection <byte-array> }
+{ $subsection 1byte-array }
+{ $subsection 2byte-array }
+{ $subsection 3byte-array }
+{ $subsection 4byte-array }
+"Resizing byte-arrays:"
+{ $subsection resize-byte-array } ;
ABOUT: "byte-arrays"
{ $description
"Outputs a freshly-allocated byte array whose elements have the same signed byte values as a given sequence." }
{ $errors "Throws an error if the sequence contains elements other than integers." } ;
+
+HELP: 1byte-array
+{ $values
+ { "x" object }
+ { "byte-array" byte-array } }
+{ $description "Creates a new byte-array with one element." } ;
+
+HELP: 2byte-array
+{ $values
+ { "x" object } { "y" object }
+ { "byte-array" byte-array } }
+{ $description "Creates a new byte-array with two elements." } ;
+
+HELP: 3byte-array
+{ $values
+ { "x" object } { "y" object } { "z" object }
+ { "byte-array" byte-array } }
+{ $description "Creates a new byte-array with three element." } ;
+
+HELP: 4byte-array
+{ $values
+ { "w" object } { "x" object } { "y" object } { "z" object }
+ { "byte-array" byte-array } }
+{ $description "Creates a new byte-array with four elements." } ;
+
+{ 1byte-array 2byte-array 3byte-array 4byte-array } related-words
+
+HELP: resize-byte-array ( n byte-array -- newbyte-array )
+{ $values { "n" "a non-negative integer" } { "byte-array" byte-array }
+ { "newbyte-array" byte-array } }
+{ $description "Creates a new byte-array of n elements. The contents of the existing byte-array are copied into the new byte-array; if the new byte-array is shorter, only an initial segment is copied, and if the new byte-array is longer the remaining space is filled in with 0." } ;
INSTANCE: byte-array sequence
-: 1byte-array ( x -- array ) 1 <byte-array> [ set-first ] keep ; inline
+: 1byte-array ( x -- byte-array ) 1 <byte-array> [ set-first ] keep ; inline
-: 2byte-array ( x y -- array ) B{ } 2sequence ; inline
+: 2byte-array ( x y -- byte-array ) B{ } 2sequence ; inline
-: 3byte-array ( x y z -- array ) B{ } 3sequence ; inline
+: 3byte-array ( x y z -- byte-array ) B{ } 3sequence ; inline
-: 4byte-array ( w x y z -- array ) B{ } 4sequence ; inline
+: 4byte-array ( w x y z -- byte-array ) B{ } 4sequence ; inline
$nl
"Classes themselves form a class:"
{ $subsection class? }
-"You can ask an object for its class:"
+"You can ask an object for its class or superclass:"
{ $subsection class }
+{ $subsection superclass }
+{ $subsection superclasses }
"Testing if an object is an instance of a class:"
{ $subsection instance? }
"Class predicates can be used to test instances directly:"
HELP: superclass
{ $values { "class" class } { "super" class } }
-{ $description "Outputs the superclass of a class. All instances of this class are also instances of the superclass." } ;
+{ $description "Outputs the superclass of a class. All instances of this class are also instances of the superclass." }
+{ $examples
+ { $example "USING: classes prettyprint ;"
+ "t superclass ."
+ "word"
+ }
+} ;
+
+HELP: superclasses
+{ $values
+ { "class" class }
+ { "supers" sequence } }
+{ $description "Outputs a sequence of superclasses of a class along with the class itself." }
+{ $examples
+ { $example "USING: classes prettyprint ;"
+ "t superclasses ."
+ "{ word t }"
+ }
+} ;
+
+{ superclass superclasses } related-words
HELP: members
{ $values { "class" class } { "seq" "a sequence of union members, or " { $link f } } }
HELP: implementors
{ $values { "class/classes" "a class or a sequence of classes" } { "seq" "a sequence of generic words" } }
{ $description "Finds all generic words in the dictionary implementing methods for the given set of classes." } ;
+
+HELP: instance?
+{ $values
+ { "object" object } { "class" class }
+ { "?" "a boolean" } }
+{ $description "Tests whether the input object is a member of the class." } ;
] with-compilation-unit
] unit-test
+TUPLE: syntax-test bar baz ;
+[ T{ syntax-test } ] [ T{ syntax-test } ] unit-test
+[ T{ syntax-test f { 2 3 } { 4 { 5 } } } ]
+[ T{ syntax-test { bar { 2 3 } } { baz { 4 { 5 } } } } ] unit-test
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel sets namespaces sequences parser
-lexer combinators words classes.parser classes.tuple arrays ;
+lexer combinators words classes.parser classes.tuple arrays
+slots math assocs ;
IN: classes.tuple.parser
: slot-names ( slots -- seq )
dup check-duplicate-slots
3dup check-slot-shadowing ;
-: literal>tuple ( seq -- tuple )
- {
- { [ dup length 1 = ] [ first new ] }
- { [ dup second not ] [ [ 2 tail ] [ first ] bi slots>tuple ] }
- [ "Not implemented" throw ]
- } cond ;
+: parse-slot-value ( -- )
+ scan scan-object 2array , scan "}" assert= ;
+
+: (parse-slot-values) ( -- )
+ parse-slot-value
+ scan {
+ { "{" [ (parse-slot-values) ] }
+ { "}" [ ] }
+ } case ;
+
+: parse-slot-values ( -- )
+ [ (parse-slot-values) ] { } make ;
+
+: boa>tuple ( class slots -- tuple )
+ swap prefix >tuple ;
+
+: assoc>tuple ( class slots -- tuple )
+ [ [ ] [ initial-values ] [ all-slots ] tri ] dip
+ swap [ [ slot-named offset>> 2 - ] curry dip ] curry assoc-map
+ [ dup <enum> ] dip update boa>tuple ;
+
+: parse-tuple-literal ( -- tuple )
+ scan-word scan {
+ { "f" [ \ } parse-until boa>tuple ] }
+ { "{" [ parse-slot-values assoc>tuple ] }
+ { "}" [ new ] }
+ } case ;
"IN: scratchpad"
"TUPLE: employee number name department ;"
"employee new ."
- "T{ employee f f f f }"
+ "T{ employee }"
}
} ;
] 2each
] if-bootstrapping ; inline
+PRIVATE>
+
: initial-values ( class -- slots )
all-slots [ initial>> ] map ;
: pad-slots ( slots class -- slots' class )
[ initial-values over length tail append ] keep ; inline
-PRIVATE>
-
: tuple>array ( tuple -- array )
prepare-tuple>array
>r copy-tuple-slots r>
{ $subsection while }
"Generalization of " { $link bi } " and " { $link tri } ":"
{ $subsection cleave }
+"Generalization of " { $link 2bi } " and " { $link 2tri } ":"
+{ $subsection 2cleave }
+"Generalization of " { $link 3bi } " and " { $link 3tri } ":"
+{ $subsection 3cleave }
"Generalization of " { $link bi* } " and " { $link tri* } ":"
{ $subsection spread }
"Two combinators which abstract out nested chains of " { $link if } ":"
}
} ;
+HELP: 2cleave
+{ $values { "x" object } { "y" object }
+ { "seq" "a sequence of quotations with stack effect " { $snippet "( x y -- ... )" } } }
+{ $description "Applies each quotation to the two objects in turn." } ;
+
+HELP: 3cleave
+{ $values { "x" object } { "y" object } { "z" object }
+ { "seq" "a sequence of quotations with stack effect " { $snippet "( x y z -- ... )" } } }
+{ $description "Applies each quotation to the three objects in turn." } ;
+
{ bi tri cleave } related-words
HELP: spread
[ [ keep ] curry ] map concat [ drop ] append [ ] like ;
! 2cleave
-: 2cleave ( x seq -- )
+: 2cleave ( x y seq -- )
[ 2keep ] each 2drop ;
: 2cleave>quot ( seq -- quot )
[ [ 2keep ] curry ] map concat [ 2drop ] append [ ] like ;
! 3cleave
-: 3cleave ( x seq -- )
+: 3cleave ( x y z seq -- )
[ 3keep ] each 3drop ;
: 3cleave>quot ( seq -- quot )
: shuffled-values ( shuffle -- values )
out>> [ get ] map ;
-: shuffle* ( stack shuffle -- newstack )
- [ [ load-shuffle ] keep shuffled-values ] with-scope ;
-
: shuffle ( stack shuffle -- newstack )
- [ split-shuffle ] keep shuffle* append ;
+ [ [ load-shuffle ] keep shuffled-values ] with-scope ;
: path-separator ( -- string ) os windows? "\\" "/" ? ;
-: right-trim-separators ( str -- newstr )
- [ path-separator? ] right-trim ;
+: trim-right-separators ( str -- newstr )
+ [ path-separator? ] trim-right ;
-: left-trim-separators ( str -- newstr )
- [ path-separator? ] left-trim ;
+: trim-left-separators ( str -- newstr )
+ [ path-separator? ] trim-left ;
: last-path-separator ( path -- n ? )
[ length 1- ] keep [ path-separator? ] find-last-from ;
: parent-directory ( path -- parent )
dup root-directory? [
- right-trim-separators
+ trim-right-separators
dup last-path-separator [
1+ cut
] [
: append-path-empty ( path1 path2 -- path' )
{
{ [ dup head.? ] [
- rest left-trim-separators append-path-empty
+ rest trim-left-separators append-path-empty
] }
{ [ dup head..? ] [ drop no-parent-directory ] }
[ nip ]
{
{ [ over empty? ] [ append-path-empty ] }
{ [ dup empty? ] [ drop ] }
- { [ over right-trim-separators "." = ] [ nip ] }
+ { [ over trim-right-separators "." = ] [ nip ] }
{ [ dup absolute-path? ] [ nip ] }
- { [ dup head.? ] [ rest left-trim-separators append-path ] }
+ { [ dup head.? ] [ rest trim-left-separators append-path ] }
{ [ dup head..? ] [
- 2 tail left-trim-separators
+ 2 tail trim-left-separators
>r parent-directory r> append-path
] }
{ [ over absolute-path? over first path-separator? and ] [
>r 2 head r> append
] }
[
- >r right-trim-separators "/" r>
- left-trim-separators 3append
+ >r trim-right-separators "/" r>
+ trim-left-separators 3append
]
} cond ;
: file-name ( path -- string )
dup root-directory? [
- right-trim-separators
+ trim-right-separators
dup last-path-separator [ 1+ tail ] [
drop "resource:" ?head [ file-name ] when
] if
: (normalize-path) ( path -- path' )
"resource:" ?head [
- left-trim-separators resource-path
+ trim-left-separators resource-path
(normalize-path)
] [
current-directory get prepend-path
HOOK: make-directory io-backend ( path -- )
: make-directories ( path -- )
- normalize-path right-trim-separators {
+ normalize-path trim-right-separators {
{ [ dup "." = ] [ ] }
{ [ dup root-directory? ] [ ] }
{ [ dup empty? ] [ ] }
"arrays"
"assocs"
"combinators"
+ "compiler"
"compiler.errors"
+ "compiler.units"
"continuations"
"debugger"
"definitions"
"editors"
- "generic"
"help"
"inspector"
"io"
"kernel"
"listener"
"math"
+ "math.order"
"memory"
"namespaces"
"prettyprint"
{ $subsection find-last }
{ $subsection find-last-from } ;
+ARTICLE: "sequences-trimming" "Trimming sequences"
+"Trimming words:"
+{ $subsection trim }
+{ $subsection trim-left }
+{ $subsection trim-right }
+"Potentially more efficient trim:"
+{ $subsection trim-slice }
+{ $subsection trim-left-slice }
+{ $subsection trim-right-slice } ;
+
ARTICLE: "sequences-destructive" "Destructive operations"
"These words modify their input, instead of creating a new sequence."
$nl
{ $subsection "sequences-sorting" }
{ $subsection "binary-search" }
{ $subsection "sets" }
+{ $subsection "sequences-trimming" }
"For inner loops:"
{ $subsection "sequences-unsafe" } ;
{ $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." }
HELP: padding
{ $values { "seq" sequence } { "n" "a non-negative integer" } { "elt" object } { "quot" "a quotation with stack effect " { $snippet "( seq1 seq2 -- newseq )" } } { "newseq" "a new sequence" } }
-{ $description "Outputs a new string sequence of " { $snippet "elt" } " repeated, that when appended to " { $snippet "seq" } ", yields a sequence of length " { $snippet "n" } ". If the length of { " { $snippet "seq" } " is greater than " { $snippet "n" } ", this word outputs an empty sequence." } ;
+{ $description "Outputs a new string sequence of " { $snippet "elt" } " repeated, that when appended to " { $snippet "seq" } ", yields a sequence of length " { $snippet "n" } ". If the length of " { $snippet "seq" } " is greater than " { $snippet "n" } ", this word outputs an empty sequence." } ;
HELP: pad-left
{ $values { "seq" sequence } { "n" "a non-negative integer" } { "elt" object } { "padded" "a new sequence" } }
"50"
} ;
+HELP: pusher
+{ $values
+ { "quot" "a predicate quotation" }
+ { "quot" quotation } { "accum" vector } }
+{ $description "Creates a new vector to accumulate the values which return true for a predicate. Returns a new quotation which accepts an object to be tested and stored in the accumulator if the test yields true. The accumulator is left on the stack for convenience." }
+{ $example "! Find all the even numbers:" "USING: prettyprint sequences math kernel ;"
+ "10 [ even? ] pusher [ each ] dip ."
+ "V{ 0 2 4 6 8 }"
+}
+{ $notes "Used to implement the " { $link filter } " word." } ;
+
+HELP: trim-left
+{ $values
+ { "seq" sequence } { "quot" quotation }
+ { "newseq" sequence } }
+{ $description "Removes elements starting from the left side of a sequence if they match a predicate. Once an element does not match, the test stops and the rest of the sequence is left on the stack as a new sequence." }
+{ $example "" "USING: prettyprint math sequences ;"
+ "{ 0 0 1 2 3 0 0 } [ zero? ] trim-left ."
+ "{ 1 2 3 0 0 }"
+} ;
+
+HELP: trim-right
+{ $values
+ { "seq" sequence } { "quot" quotation }
+ { "newseq" sequence } }
+{ $description "Removes elements starting from the right side of a sequence if they match a predicate. Once an element does not match, the test stops and the rest of the sequence is left on the stack as a new sequence." }
+{ $example "" "USING: prettyprint math sequences ;"
+ "{ 0 0 1 2 3 0 0 } [ zero? ] trim-right ."
+ "{ 0 0 1 2 3 }"
+} ;
+
+HELP: trim
+{ $values
+ { "seq" sequence } { "quot" quotation }
+ { "newseq" sequence } }
+{ $description "Removes elements starting from the left and right sides of a sequence if they match a predicate. Once an element does not match, the test stops and the rest of the sequence is left on the stack as a new sequence." }
+{ $example "" "USING: prettyprint math sequences ;"
+ "{ 0 0 1 2 3 0 0 } [ zero? ] trim ."
+ "{ 1 2 3 }"
+} ;
+
+{ trim-left trim-right trim } related-words
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 <slice> >vector ] unit-test
[ 3 ] [ 1 4 dup <slice> length ] unit-test
[ 2 ] [ 1 3 { 1 2 3 4 } <slice> length ] unit-test
[ -1./0. 0 delete-nth ] must-fail
[ "" ] [ "" [ CHAR: \s = ] trim ] unit-test
-[ "" ] [ "" [ CHAR: \s = ] left-trim ] unit-test
-[ "" ] [ "" [ CHAR: \s = ] right-trim ] unit-test
-[ "" ] [ " " [ CHAR: \s = ] left-trim ] unit-test
-[ "" ] [ " " [ CHAR: \s = ] right-trim ] unit-test
+[ "" ] [ "" [ CHAR: \s = ] trim-left ] unit-test
+[ "" ] [ "" [ CHAR: \s = ] trim-right ] unit-test
+[ "" ] [ " " [ CHAR: \s = ] trim-left ] unit-test
+[ "" ] [ " " [ CHAR: \s = ] trim-right ] unit-test
[ "asdf" ] [ " asdf " [ CHAR: \s = ] trim ] unit-test
-[ "asdf " ] [ " asdf " [ CHAR: \s = ] left-trim ] unit-test
-[ " asdf" ] [ " asdf " [ CHAR: \s = ] right-trim ] unit-test
+[ "asdf " ] [ " asdf " [ CHAR: \s = ] trim-left ] unit-test
+[ " asdf" ] [ " asdf " [ CHAR: \s = ] trim-right ] unit-test
[ 328350 ] [ 100 [ sq ] sigma ] unit-test
M: bogus-hashcode hashcode* 2drop 0 >bignum ;
[ 0 ] [ { T{ bogus-hashcode } } hashcode ] unit-test
+
+[ { 2 4 6 } { 1 3 5 7 } ] [ { 1 2 3 4 5 6 7 } [ even? ] partition ] unit-test
+
+[ { 1 3 7 } ] [ 2 { 1 3 5 7 } remove-nth ] unit-test
+
+[ { 1 3 "X" 5 7 } ] [ "X" 2 { 1 3 5 7 } insert-nth ] unit-test
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
: filter ( seq quot -- subseq )
over >r pusher >r each r> r> like ; inline
+: push-either ( elt quot accum1 accum2 -- )
+ >r >r keep swap r> r> ? push ; inline
+
+: 2pusher ( quot -- quot accum1 accum2 )
+ V{ } clone V{ } clone [ [ push-either ] 3curry ] 2keep ; inline
+
+: partition ( seq quot -- trueseq falseseq )
+ over >r 2pusher >r >r each r> r> r> tuck [ like ] 2bi@ ; inline
+
: monotonic? ( seq quot -- ? )
>r dup length 1- swap r> (monotonic) all? ; inline
[ >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 ;
: 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 )
dup slice? [ { } like ] when 0 over length rot <slice> ;
inline
-: left-trim ( seq quot -- newseq )
+: trim-left-slice ( seq quot -- slice )
over >r [ not ] compose find drop r> swap
- [ tail ] [ dup length tail ] if* ; inline
+ [ tail-slice ] [ dup length tail-slice ] if* ; inline
+
+: trim-left ( seq quot -- newseq )
+ over [ trim-left-slice ] dip like ; inline
-: right-trim ( seq quot -- newseq )
+: trim-right-slice ( seq quot -- slice )
over >r [ not ] compose find-last drop r> swap
- [ 1+ head ] [ 0 head ] if* ; inline
+ [ 1+ head-slice ] [ 0 head-slice ] if* ; inline
+
+: trim-right ( seq quot -- newseq )
+ over [ trim-right-slice ] dip like ; inline
+
+: trim-slice ( seq quot -- slice )
+ [ trim-left-slice ] [ trim-right-slice ] bi ; inline
: trim ( seq quot -- newseq )
- [ left-trim ] [ right-trim ] bi ; inline
+ over [ trim-slice ] dip like ; inline
: sum ( seq -- n ) 0 [ + ] binary-reduce ;
HELP: T{
{ $syntax "T{ class slots... }" }
-{ $values { "class" "a tuple class word" } { "slots" "list of objects" } }
-{ $description "Marks the beginning of a literal tuple. Literal tuples are terminated by " { $link POSTPONE: } } "."
+{ $values { "class" "a tuple class word" } { "slots" "slot values" } }
+{ $description "Marks the beginning of a literal tuple."
$nl
-"The class word must always be specified. If an insufficient number of values is given after the class word, the remaining slots of the tuple are set to " { $link f } ". If too many values are given, they are ignored." } ;
+"Three literal syntax forms are recognized:"
+{ $list
+ { "empty tuple form: if no slot values are specified, then the literal tuple will have all slots set to their initial values (see " { $link "slot-initial-values" } ")." }
+ { "BOA-form: if the first element of " { $snippet "slots" } " is " { $snippet "f" } ", then the remaining elements are slot values corresponding to slots in the order in which they are defined in the " { $link POSTPONE: TUPLE: } " form." }
+ { "assoc-form: otherwise, " { $snippet "slots" } " is interpreted as a sequence of " { $snippet "{ slot-name value }" } " pairs. The " { $snippet "slot-name" } " should not be quoted." }
+}
+"BOA form is more concise, whereas assoc form is more readable for larger tuples with many slots, or if only a few slots are to be specified."
+$nl
+"With BOA form, specifying an insufficient number of values is given after the class word, the remaining slots of the tuple are set to their initial values (see " { $link "slot-initial-values" } "). If too many values are given, an error will be raised." }
+{ $examples
+"An empty tuple; since vectors have their own literal syntax, the above is equivalent to " { $snippet "V{ }" } ""
+{ $code "T{ vector }" }
+"A BOA-form tuple:"
+{ $code
+ "USE: colors"
+ "T{ rgba f 1.0 0.0 0.5 }"
+}
+"An assoc-form tuple equal to the above:"
+{ $code
+ "USE: colors"
+ "T{ rgba { red 1.0 } { green 0.0 } { blue 0.5 } }"
+} } ;
HELP: W{
{ $syntax "W{ object }" }
"B{" [ \ } [ >byte-array ] parse-literal ] define-syntax
"BV{" [ \ } [ >byte-vector ] parse-literal ] define-syntax
"H{" [ \ } [ >hashtable ] parse-literal ] define-syntax
- "T{" [ \ } [ literal>tuple ] parse-literal ] define-syntax
+ "T{" [ parse-tuple-literal parsed ] define-syntax
"W{" [ \ } [ first <wrapper> ] parse-literal ] define-syntax
"POSTPONE:" [ scan-word parsed ] define-syntax
VAR: background
-: set-initial-background ( -- ) T{ hsva syntax:f 0 0 1 1 } clone >self ;
+: set-initial-background ( -- ) T{ hsva f 0 0 1 1 } clone >self ;
: set-background ( -- )
set-initial-background
VAR: start-shape
-: set-initial-color ( -- ) T{ hsva syntax:f 0 0 0 1 } clone >self ;
+: set-initial-color ( -- ) T{ hsva f 0 0 0 1 } clone >self ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
C[ dlist get [ dlist get 1 glDeleteLists ] when ] >>ungraft
<handler>
H{ } clone
- T{ key-down syntax:f syntax:f "ENTER" } C[ drop rebuild ] swap pick set-at
+ T{ key-down f f "ENTER" } C[ drop rebuild ] swap pick set-at
T{ button-down } C[ drop rebuild ] swap pick set-at
>>table ;
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 <slice> ; 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 <string> %
- 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 <string> %
- 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> <slice> 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 ;
--- /dev/null
+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 ;
+
+: <link> ( 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 ;
--- /dev/null
+Doug Coleman
--- /dev/null
+Doug Coleman
--- /dev/null
+USING: html.parser kernel tools.test ;
+IN: html.parser.tests
+
+[
+ V{ T{ tag f "html" H{ } f f } }
+] [ "<html>" parse-html ] unit-test
+
+[
+ V{ T{ tag f "html" H{ } f t } }
+] [ "</html>" parse-html ] unit-test
+
+[
+ V{ T{ tag f "a" H{ { "href" "http://factorcode.org/" } } f f } }
+] [ "<a href=\"http://factorcode.org/\">" parse-html ] unit-test
+
+[
+ V{ T{ tag f "a" H{ { "href" "http://factorcode.org/" } } f f } }
+] [ "<a href = \"http://factorcode.org/\" >" parse-html ] unit-test
+
+[
+V{
+ T{
+ tag
+ f
+ "a"
+ H{ { "baz" "\"quux\"" } { "foo" "bar's" } }
+ f
+ f
+ }
+}
+] [ "<a foo=\"bar's\" baz='\"quux\"' >" parse-html ] unit-test
+
+[
+V{
+ T{ tag f "a"
+ H{
+ { "a" "pirsqd" }
+ { "foo" "bar" }
+ { "href" "http://factorcode.org/" }
+ { "baz" "quux" }
+ } f f }
+}
+] [ "<a href = \"http://factorcode.org/\" foo = bar baz='quux'a=pirsqd >" 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 }
+}
+] [ "<html<head</head</html" parse-html ] unit-test
+
+[
+V{
+ T{ tag f "head" H{ } f f }
+ T{ tag f "title" H{ } f f }
+ T{ tag f text f "Spagna" f }
+ T{ tag f "title" H{ } f t }
+ T{ tag f "head" H{ } f t }
+}
+] [ "<head<title>Spagna</title></head" parse-html ] unit-test
--- /dev/null
+USING: accessors arrays html.parser.utils hashtables io kernel
+namespaces prettyprint quotations
+sequences splitting state-parser strings unicode.categories unicode.case
+sequences.lib ;
+IN: html.parser
+
+TUPLE: tag name attributes text closing? ;
+
+SINGLETON: text
+SINGLETON: dtd
+SINGLETON: comment
+SYMBOL: tagstack
+
+: push-tag ( tag -- )
+ tagstack get push ;
+
+: closing-tag? ( string -- ? )
+ [ f ]
+ [ [ first ] [ peek ] bi [ CHAR: / = ] bi@ or ] if-empty ;
+
+: <tag> ( name attributes closing? -- tag )
+ tag new
+ swap >>closing?
+ swap >>attributes
+ swap >>name ;
+
+: make-tag ( string attribs -- tag )
+ >r [ closing-tag? ] keep "/" trim1 r> rot <tag> ;
+
+: 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 ;
--- /dev/null
+Doug Coleman
--- /dev/null
+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 text>> write "-->" write ;
+
+M: html-printer print-dtd-tag ( tag -- )
+ "<!" write text>> 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
+ name>> 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 <repetition> write ;
+
+M: html-prettyprinter print-opening-tag ( tag -- )
+ print-tabs "<" write
+ name>> write
+ ">\n" write ;
+
+M: html-prettyprinter print-closing-tag ( tag -- )
+ "</" write
+ name>> write
+ ">" write ;
--- /dev/null
+Doug Coleman
--- /dev/null
+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
+
--- /dev/null
+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 <circular-string>
+ [ 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? ;
! 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 ;
! 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
! 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 )
! 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 )
! 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
+++ /dev/null
-Chris Double
+++ /dev/null
-! Copyright (C) 2006 Chris Double.
-! See http://factorcode.org/license.txt for BSD license.
-USING: help.markup help.syntax namespaces assocs sequences
-kernel combinators ;
-IN: match
-
-HELP: match
-{ $values { "value1" object } { "value2" object } { "bindings" assoc }
-}
-{ $description "Pattern match value1 against value2. These values can be any Factor value, including sequences and tuples. The values can contain pattern variables, which are symbols that begin with '?'. The result is a hashtable of the bindings, mapping the pattern variables from one sequence to the equivalent value in the other sequence. The '_' symbol can be used to ignore the value at that point in the pattern for the match. " }
-{ $examples
- { $unchecked-example "USE: match" "MATCH-VARS: ?a ?b ;\n{ ?a { 2 ?b } 5 } { 1 { 2 3 } _ } match ." "H{ { ?a 1 } { ?b 3 } }" }
-}
-{ $see-also match-cond POSTPONE: MATCH-VARS: replace-patterns match-replace } ;
-
-HELP: match-cond
-{ $values { "assoc" "a sequence of pairs" } }
-{ $description "Calls the second quotation in the first pair whose first sequence yields a successful " { $link match } " against the top of the stack. The second quotation, when called, has the hashtable returned from the " { $link match } " call bound as the top namespace so " { $link get } " can be used to retrieve the values. To have a fallthrough match clause use the '_' match variable." }
-{ $examples
- { $code "USE: match" "MATCH-VARS: ?value ;\n{ increment ?value } {\n { { increment ?value } [ ?value do-something ] }\n { { decrement ?value } [ ?value do-something-else ] }\n { _ [ no-match-found ] }\n} match-cond" }
-}
-{ $see-also match POSTPONE: MATCH-VARS: replace-patterns match-replace } ;
-
-
-HELP: MATCH-VARS:
-{ $syntax "MATCH-VARS: var ... ;" }
-{ $values { "var" "a match variable name beginning with '?'" } }
-{ $description "Creates a symbol that can be used in " { $link match } " and " { $link match-cond } " for binding values in the matched sequence. The symbol name is created as a word that is defined to get the value of the symbol out of the current namespace. This can be used in " { $link match-cond } " to retrive the values in the quotation body." }
-{ $examples
- { $code "USE: match" "MATCH-VARS: ?value ;\n{ increment ?value } {\n { { increment ?value } [ ?value do-something ] }\n { { decrement ?value } [ ?value do-something-else ] }\n { _ [ no-match-found ] }\n} match-cond" }
-}
-{ $see-also match match-cond replace-patterns match-replace } ;
-
-HELP: replace-patterns
-{ $values { "object" object } { "result" object } }
-{ $description "Copy the object, replacing each occurrence of a pattern matching variable with the actual value of that variable." }
-{ $see-also match-cond POSTPONE: MATCH-VARS: match-replace } ;
-
-HELP: match-replace
-{ $values { "object" object } { "pattern1" object } { "pattern2" object } { "result" object } }
-{ $description "Matches the " { $snippet "object" } " against " { $snippet "pattern1" } ". The pattern match variables in " { $snippet "pattern1" } " are assigned the values from the matching " { $snippet "object" } ". These are then replaced into the " { $snippet "pattern2" } " pattern match variables." }
-{ $examples
- { $example
- "USING: match prettyprint ;"
- "IN: scratchpad"
- "MATCH-VARS: ?a ?b ;"
- "{ 1 2 } { ?a ?b } { ?b ?a } match-replace ."
- "{ 2 1 }"
- }
-}
-{ $see-also match-cond POSTPONE: MATCH-VARS: } ;
-
-ARTICLE: "match" "Pattern matching"
-"The " { $vocab-link "match" } " vocabulary implements ML-style pattern matching."
-$nl
-"Variables used for pattern matching must be explicitly defined first:"
-{ $subsection POSTPONE: MATCH-VARS: }
-"A basic pattern match:"
-{ $subsection match }
-"A conditional form analogous to " { $link cond } ":"
-{ $subsection match-cond }
-"Pattern replacement:"
-{ $subsection match-replace } ;
-
-ABOUT: "match"
+++ /dev/null
-! Copyright (C) 2006 Chris Double.
-! See http://factorcode.org/license.txt for BSD license.
-USING: tools.test match namespaces arrays ;
-IN: match.tests
-
-MATCH-VARS: ?a ?b ;
-
-[ f ] [ { ?a ?a } { 1 2 } match ] unit-test
-
-[ H{ { ?a 1 } { ?b 2 } } ] [
- { ?a ?b } { 1 2 } match
-] unit-test
-
-[ { 1 2 } ] [
- { 1 2 }
- {
- { { ?a ?b } [ ?a ?b 2array ] }
- } match-cond
-] unit-test
-
-[ t ] [
- { 1 2 }
- {
- { { 1 2 } [ t ] }
- { f [ f ] }
- } match-cond
-] unit-test
-
-[ t ] [
- { 1 3 }
- {
- { { 1 2 } [ t ] }
- { { 1 3 } [ t ] }
- } match-cond
-] unit-test
-
-[ f ] [
- { 1 5 }
- {
- { { 1 2 } [ t ] }
- { { 1 3 } [ t ] }
- { _ [ f ] }
- } match-cond
-] unit-test
-
-TUPLE: foo a b ;
-
-C: <foo> foo
-
-{ 1 2 } [
- 1 2 <foo> T{ foo f ?a ?b } match [
- ?a ?b
- ] bind
-] unit-test
-
-{ 1 2 } [
- 1 2 <foo> \ ?a \ ?b <foo> match [
- ?a ?b
- ] bind
-] unit-test
-
-{ H{ { ?a ?a } } } [
- \ ?a \ ?a match
-] unit-test
-
-[ "match" ] [
- "abcd" {
- { ?a [ "match" ] }
- } match-cond
-] unit-test
-
-[
- { 2 1 }
-] [
- { "a" 1 2 "b" } { _ ?a ?b _ } { ?b ?a } match-replace
-] unit-test
-
-TUPLE: match-replace-test a b ;
-
-[
- T{ match-replace-test f 2 1 }
-] [
- T{ match-replace-test f 1 2 }
- T{ match-replace-test f ?a ?b }
- T{ match-replace-test f ?b ?a }
- match-replace
-] unit-test
+++ /dev/null
-! Copyright (C) 2006 Chris Double.
-! See http://factorcode.org/license.txt for BSD license.
-!
-! Based on pattern matching code from Paul Graham's book 'On Lisp'.
-USING: parser lexer kernel words namespaces sequences classes.tuple
-combinators macros assocs math effects ;
-IN: match
-
-SYMBOL: _
-
-: define-match-var ( name -- )
- create-in
- dup t "match-var" set-word-prop
- dup [ get ] curry (( -- value )) define-declared ;
-
-: define-match-vars ( seq -- )
- [ define-match-var ] each ;
-
-: MATCH-VARS: ! vars ...
- ";" parse-tokens define-match-vars ; parsing
-
-: match-var? ( symbol -- bool )
- dup word? [ "match-var" word-prop ] [ drop f ] if ;
-
-: set-match-var ( value var -- ? )
- dup namespace key? [ get = ] [ set t ] if ;
-
-: (match) ( value1 value2 -- matched? )
- {
- { [ dup match-var? ] [ set-match-var ] }
- { [ over match-var? ] [ swap set-match-var ] }
- { [ 2dup = ] [ 2drop t ] }
- { [ 2dup [ _ eq? ] either? ] [ 2drop t ] }
- { [ 2dup [ sequence? ] both? ] [
- 2dup [ length ] bi@ =
- [ [ (match) ] 2all? ] [ 2drop f ] if ] }
- { [ 2dup [ tuple? ] both? ]
- [ [ tuple>array ] bi@ [ (match) ] 2all? ] }
- { [ t ] [ 2drop f ] }
- } cond ;
-
-: match ( value1 value2 -- bindings )
- [ (match) ] H{ } make-assoc swap [ drop f ] unless ;
-
-MACRO: match-cond ( assoc -- )
- <reversed>
- [ "Fall-through in match-cond" throw ]
- [
- first2
- >r [ dupd match ] curry r>
- [ bind ] curry rot
- [ ?if ] 2curry append
- ] reduce ;
-
-: replace-patterns ( object -- result )
- {
- { [ dup number? ] [ ] }
- { [ dup match-var? ] [ get ] }
- { [ dup sequence? ] [ [ replace-patterns ] map ] }
- { [ dup tuple? ] [ tuple>array replace-patterns >tuple ] }
- [ ]
- } cond ;
-
-: match-replace ( object pattern1 pattern2 -- result )
- -rot
- match [ "Pattern does not match" throw ] unless*
- [ replace-patterns ] bind ;
-
-: ?1-tail ( seq -- tail/f )
- dup length zero? not [ rest ] [ drop f ] if ;
-
-: (match-first) ( seq pattern-seq -- bindings leftover/f )
- 2dup [ length ] bi@ < [ 2drop f f ]
- [
- 2dup length head over match
- [ nip swap ?1-tail ] [ >r rest r> (match-first) ] if*
- ] if ;
-
-: match-first ( seq pattern-seq -- bindings )
- (match-first) drop ;
-
-: (match-all) ( seq pattern-seq -- )
- tuck (match-first) swap
- [
- , [ swap (match-all) ] [ drop ] if*
- ] [ 2drop ] if* ;
-
-: match-all ( seq pattern-seq -- bindings-seq )
- [ (match-all) ] { } make ;
-
+++ /dev/null
-ML-style pattern matching
+++ /dev/null
-extensions
+++ /dev/null
-! 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
-
-<PRIVATE
-
-DEFER: byte-bit-count
-
-<<
-
-\ byte-bit-count
-256 [
- 0 swap [ [ 1+ ] when ] each-bit
-] B{ } map-as '[ HEX: ff bitand , nth-unsafe ] define-inline
-
->>
-
-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
+++ /dev/null
-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" }
-} ;
-
+++ /dev/null
-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
+++ /dev/null
-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 ;
-
M: double-complex-blas-matrix pprint-delims drop \ zmatrix{ \ } ;
M: blas-vector-base >pprint-sequence ;
+M: blas-vector-base pprint* pprint-object ;
M: blas-matrix-base >pprint-sequence Mrows ;
+M: blas-matrix-base pprint* pprint-object ;
: p= ( p p -- ? ) pextend = ;
: ptrim ( p -- p )
- dup length 1 = [ [ zero? ] right-trim ] unless ;
+ dup length 1 = [ [ zero? ] trim-right ] unless ;
: 2ptrim ( p p -- p p ) [ ptrim ] bi@ ;
: p+ ( p p -- p ) pextend v+ ;
: dollars/cents ( dollars -- dollars cents )
100 * 100 /mod round ;
-: money. ( object -- )
- dollars/cents
- [
+: money>string ( object -- string )
+ dollars/cents [
"$" %
swap number>string
<reversed> 3 group "," join <reversed> %
"." % number>string 2 CHAR: 0 pad-left %
- ] "" make print ;
+ ] "" make ;
+
+: money. ( object -- )
+ money>string print ;
ERROR: not-a-decimal x ;
-IN: namespaces.lib.tests\r
-USING: namespaces.lib kernel tools.test ;\r
\r
-[ ] [ [ ] { } nmake ] unit-test\r
-\r
-[ { 1 } { 2 } ] [ [ 1 0, 2 1, ] { { } { } } nmake ] unit-test\r
-\r
-[ [ ] [ call ] curry { { } } nmake ] must-infer\r
: 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 [ <mirror> swap bind ] keep ; inline
--- /dev/null
+Joe Groff
\ No newline at end of file
--- /dev/null
+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"
--- /dev/null
+! 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) ;
--- /dev/null
+Testing for OpenGL versions and extensions
\ No newline at end of file
--- /dev/null
+opengl
+bindings
--- /dev/null
+Joe Groff
\ No newline at end of file
--- /dev/null
+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
+
--- /dev/null
+Common support for OpenGL demos
\ No newline at end of file
--- /dev/null
+Joe Groff
\ No newline at end of file
--- /dev/null
+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
--- /dev/null
+! 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 <uint> [ glGetFramebufferAttachmentParameterivEXT ] keep *uint ;
--- /dev/null
+Rendering to offscreen textures using the GL_EXT_framebuffer_object extension
\ No newline at end of file
--- /dev/null
+opengl
+bindings
--- /dev/null
+IN: opengl.gadgets.tests
+USING: tools.test opengl.gadgets ;
+
+\ render* must-infer
--- /dev/null
+! 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: <entry> cache-entry
+
+: make-entry ( gadget -- entry )
+ dup render* <entry>
+ [ 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 ;
--- /dev/null
+Joe Groff
\ No newline at end of file
--- /dev/null
+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 <gl-shader> } " - 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 <vertex-shader> } " - 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 <fragment-shader> } " - Compile GLSL code into a fragment shader object "}
+ }
+} ;
+
+HELP: <gl-shader>
+{ $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: <vertex-shader>
+{ $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 <gl-shader>" } "." } ;
+
+HELP: <fragment-shader>
+{ $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 <gl-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 <gl-program> } ", " { $link <simple-gl-program> } " - 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: <gl-program>
+{ $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: <simple-gl-program>
+{ $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 <gl-program> } " 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." } ;
+
+{ <gl-program> <simple-gl-program> } 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"
--- /dev/null
+! 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 [ <void*> swap call ] keep free ; inline
+
+: <gl-shader> ( 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 <int> [ glGetShaderiv ] keep *int ;
+
+: gl-shader-ok? ( shader -- ? )
+ GL_COMPILE_STATUS gl-shader-get-int c-bool> ;
+
+: <vertex-shader> ( source -- vertex-shader )
+ GL_VERTEX_SHADER <gl-shader> ; inline
+
+: (vertex-shader?) ( object -- ? )
+ dup (gl-shader?)
+ [ GL_SHADER_TYPE gl-shader-get-int GL_VERTEX_SHADER = ]
+ [ drop f ] if ;
+
+: <fragment-shader> ( source -- fragment-shader )
+ GL_FRAGMENT_SHADER <gl-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 <int> 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
+
+: <gl-program> ( 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 <int> [ 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 <int> 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" <c-array>
+ 0 <int> 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?) ;
+
+: <simple-gl-program> ( vertex-shader-source fragment-shader-source -- program )
+ >r <vertex-shader> check-gl-shader
+ r> <fragment-shader> check-gl-shader
+ 2array <gl-program> check-gl-program ;
+
--- /dev/null
+OpenGL Shading Language (GLSL) support
\ No newline at end of file
--- /dev/null
+opengl
+glsl
+bindings
\ No newline at end of file
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
"\0" read-until [ drop f ] unless ;
: read-c-string* ( n -- str/f )
- read [ zero? ] right-trim dup empty? [ drop f ] when ;
+ read [ zero? ] trim-right dup empty? [ drop f ] when ;
: (read-128-ber) ( n -- n )
read1
parsers>> 0 swap seq>list
[ parse ] lazy-map-with lconcat ;
-: left-trim-slice ( string -- string )
+: trim-left-slice ( string -- string )
#! Return a new string without any leading whitespace
#! from the original string.
dup empty? [
- dup first blank? [ rest-slice left-trim-slice ] when
+ dup first blank? [ rest-slice trim-left-slice ] when
] unless ;
TUPLE: sp-parser p1 ;
M: sp-parser parse ( input parser -- list )
#! Skip all leading whitespace from the input then call
#! the parser on the remaining input.
- >r left-trim-slice r> p1>> parse ;
+ >r trim-left-slice r> p1>> parse ;
TUPLE: just-parser p1 ;
+++ /dev/null
-Chris Double
+++ /dev/null
-! 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 } ;
-
+++ /dev/null
-! 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
-
+++ /dev/null
-! 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 ;
-
-
+++ /dev/null
-Search and replace using parsing expression grammars
: source-059 ( -- seq )
"resource:extra/project-euler/059/cipher1.txt"
- ascii file-contents [ blank? ] right-trim "," split
+ ascii file-contents [ blank? ] trim-right "," split
[ string>number ] map ;
TUPLE: rollover seq n ;
[ { { 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
[ "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
: 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
: power-set ( seq -- subsets )
2 over length exact-number-strings swap [ switches ] curry map ;
-: push-either ( elt quot accum1 accum2 -- )
- >r >r keep swap r> r> ? push ; inline
-
-: 2pusher ( quot -- quot accum1 accum2 )
- V{ } clone V{ } clone [ [ push-either ] 3curry ] 2keep ; inline
-
-: partition ( seq quot -- trueseq falseseq )
- over >r 2pusher >r >r each r> r> r> drop ; inline
-
: cut-find ( seq pred -- before after )
dupd find drop dup [ cut ] when ;
: ?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
! 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
! 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 )
! 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 )
! 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
[ 2 <clumps> [ = not ] assoc-filter values ] [ first ] bi prefix ;
: first>upper ( seq -- seq' ) 1 head >upper ;
-: trim-first ( seq -- seq' ) dup first [ = ] curry left-trim ;
+: trim-first ( seq -- seq' ) dup first [ = ] curry trim-left ;
: remove-zeroes ( seq -- seq' ) CHAR: 0 swap remove ;
: remove-non-alpha ( seq -- seq' ) [ alpha? ] filter ;
: pad-4 ( first seq -- seq' ) "000" 3append 4 head ;
: typeflag-L ( header -- )
drop ;
! <string-writer> [ read-data-blocks ] keep
- ! >string [ zero? ] right-trim filename set
+ ! >string [ zero? ] trim-right filename set
! filename get tar-prepend-path make-directories ;
! Multi volume continuation entry
+++ /dev/null
-Daniel Ehrenberg
+++ /dev/null
-Tuple literals with named slots
+++ /dev/null
-reflection
+++ /dev/null
-USING: help.markup help.syntax ;
-IN: tuple-syntax
-
-HELP: TUPLE{
-{ $syntax "TUPLE{ class slot-name: value... }" }
-{ $values { "class" "a tuple class word" } { "slot-name" "the name of a slot, without the tuple class name" } { "value" "the value for a slot" } }
-{ $description "Marks the beginning of a literal tuple. Literal tuples are terminated by " { $link POSTPONE: } } ". The class word must be specified. Slots which aren't specified are set to f. If slot names are duplicated, the latest one is used." }
-{ $see-also POSTPONE: T{ } ;
+++ /dev/null
-USING: tools.test tuple-syntax ;
-IN: tuple-syntax.tests
-
-TUPLE: foo bar baz ;
-
-[ T{ foo } ] [ TUPLE{ foo } ] unit-test
-[ T{ foo f { 2 3 } { 4 { 5 } } } ]
-[ TUPLE{ foo bar: { 2 3 } baz: { 4 { 5 } } } ] unit-test
+++ /dev/null
-USING: classes.tuple accessors kernel sequences slots parser
-lexer words classes slots.private mirrors ;
-IN: tuple-syntax
-
-! TUPLE: foo bar baz ;
-! TUPLE{ foo bar: 1 baz: 2 }
-
-: parse-slot-writer ( tuple -- slot# )
- scan dup "}" = [ 2drop f ] [
- but-last swap class all-slots slot-named offset>>
- ] if ;
-
-: parse-slots ( accum tuple -- accum tuple )
- dup parse-slot-writer
- [ scan-object pick rot set-slot parse-slots ] when* ;
-
-: TUPLE{
- scan-word new parse-slots parsed ; parsing
--- /dev/null
+
+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 ) 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* ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
--- /dev/null
+
+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]" <c-array>
+ >>pixels ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: new-frame-buffer ( class -- gadget )
+ new-gadget
+ [ ] >>action
+ { 100 100 } >>pdim
+ [ ] >>graft
+ [ ] >>ungraft ;
+
+: <frame-buffer> ( -- 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 * <sliced-groups> ] 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 ;
+
--- /dev/null
+Eduardo Cavazos
--- /dev/null
+
+USING: kernel assocs ui.gestures ui.gadgets.wrappers accessors ;
+
+IN: ui.gadgets.handler
+
+TUPLE: handler < wrapper table ;
+
+: <handler> ( 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
--- /dev/null
+
+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 ) 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 <range> ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+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
--- /dev/null
+Eduardo Cavazos
--- /dev/null
+
+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 ;
+
+: <slate> ( 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 ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
--- /dev/null
+William Schlieper
\ No newline at end of file
--- /dev/null
+Tabbed windows
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2008 William Schlieper\r
+! See http://factorcode.org/license.txt for BSD license.\r
+\r
+USING: accessors kernel fry math math.vectors sequences arrays vectors assocs\r
+ hashtables models models.range models.compose combinators\r
+ ui ui.gadgets ui.gadgets.buttons ui.gadgets.frames ui.gadgets.packs\r
+ ui.gadgets.grids ui.gadgets.viewports ui.gadgets.books locals ;\r
+\r
+IN: ui.gadgets.tabs\r
+\r
+TUPLE: tabbed < frame names toggler content ;\r
+\r
+DEFER: (del-page)\r
+\r
+:: add-toggle ( model n name toggler -- )\r
+ <frame>\r
+ n name toggler parent>> '[ , , , (del-page) ] "X" swap <bevel-button>\r
+ @right grid-add\r
+ n model name <toggle-button> @center grid-add\r
+ toggler swap add-gadget drop ;\r
+\r
+: redo-toggler ( tabbed -- )\r
+ [ names>> ] [ model>> ] [ toggler>> ] tri\r
+ [ clear-gadget ] keep\r
+ [ [ length ] keep ] 2dip\r
+ '[ , _ _ , add-toggle ] 2each ;\r
+\r
+: refresh-book ( tabbed -- )\r
+ model>> [ ] change-model ;\r
+\r
+: (del-page) ( n name tabbed -- )\r
+ { [ [ remove ] change-names redo-toggler ]\r
+ [ dupd [ names>> length ] [ model>> ] bi\r
+ [ [ = ] keep swap [ 1- ] when\r
+ [ < ] keep swap [ 1- ] when ] change-model ]\r
+ [ content>> nth-gadget unparent ]\r
+ [ refresh-book ]\r
+ } cleave ;\r
+\r
+: add-page ( page name tabbed -- )\r
+ [ names>> push ] 2keep\r
+ [ [ model>> swap ]\r
+ [ names>> length 1 - swap ]\r
+ [ toggler>> ] tri add-toggle ]\r
+ [ content>> swap add-gadget drop ]\r
+ [ refresh-book ] tri ;\r
+\r
+: del-page ( name tabbed -- )\r
+ [ names>> index ] 2keep (del-page) ;\r
+\r
+: new-tabbed ( assoc class -- tabbed )\r
+ new-frame\r
+ 0 <model> >>model\r
+ <pile> 1 >>fill >>toggler\r
+ dup toggler>> @left grid-add\r
+ swap\r
+ [ keys >vector >>names ]\r
+ [ values over model>> <book> >>content dup content>> @center grid-add ]\r
+ bi\r
+ dup redo-toggler ;\r
+ \r
+: <tabbed> ( assoc -- tabbed ) tabbed new-tabbed ;\r
--- /dev/null
+
+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 ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: <tiling> ( -- 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 ;
+
+: <tiling-shelf> ( -- gadget )
+ tiling-shelf new init-tiling { 1 0 } >>orientation ;
+
+: <tiling-pile> ( -- 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
--- /dev/null
+Doug Coleman
--- /dev/null
+Doug Coleman
--- /dev/null
+! 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 } <dimensioned> ;
+
--- /dev/null
+
+ 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
--- /dev/null
+Doug Coleman
--- /dev/null
+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
+
--- /dev/null
+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..
--- /dev/null
+Doug Coleman
--- /dev/null
+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
--- /dev/null
+USING: kernel math math.constants sequences units ;
+IN: units.si
+
+! SI Conversions
+! http://physics.nist.gov/cuu/Units/
+
+! Length
+: m ( n -- dimensioned ) { m } { } <dimensioned> ;
+
+! Mass
+: kg ( n -- dimensioned ) { kg } { } <dimensioned> ;
+
+! Time
+: s ( n -- dimensioned ) { s } { } <dimensioned> ;
+
+! Electric current
+: A ( n -- dimensioned ) { A } { } <dimensioned> ;
+
+! Temperature
+: K ( n -- dimensioned ) { K } { } <dimensioned> ;
+
+! Amount of substance
+: mol ( n -- dimensioned ) { mol } { } <dimensioned> ;
+
+! Luminous intensity
+: cd ( n -- dimensioned ) { cd } { } <dimensioned> ;
+
+! SI derived units
+: m^2 ( n -- dimensioned ) { m m } { } <dimensioned> ;
+: m^3 ( n -- dimensioned ) { m m m } { } <dimensioned> ;
+: m/s ( n -- dimensioned ) { m } { s } <dimensioned> ;
+: m/s^2 ( n -- dimensioned ) { m } { s s } <dimensioned> ;
+: 1/m ( n -- dimensioned ) { } { m } <dimensioned> ;
+: kg/m^3 ( n -- dimensioned ) { kg } { m m m } <dimensioned> ;
+: A/m^2 ( n -- dimensioned ) { A } { m m } <dimensioned> ;
+: A/m ( n -- dimensioned ) { A } { m } <dimensioned> ;
+: mol/m^3 ( n -- dimensioned ) { mol } { m m m } <dimensioned> ;
+: cd/m^2 ( n -- dimensioned ) { cd } { m m } <dimensioned> ;
+: kg/kg ( n -- dimensioned ) { kg } { kg } <dimensioned> ;
+
+! 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 } <dimensioned> ;
+: N ( n -- newton ) { kg m } { s s } <dimensioned> ;
+: Pa ( n -- pascal ) { kg } { m s s } <dimensioned> ;
+: J ( n -- joule ) { m m kg } { s s } <dimensioned> ;
+: W ( n -- watt ) { m m kg } { s s s } <dimensioned> ;
+: C ( n -- coulomb ) { s A } { } <dimensioned> ;
+: V ( n -- volt ) { m m kg } { s s s A } <dimensioned> ;
+: F ( n -- farad ) { s s s s A A } { m m kg } <dimensioned> ;
+: ohm ( n -- ohm ) { m m kg } { s s s A A } <dimensioned> ;
+: S ( n -- siemens ) { s s s A A } { m m kg } <dimensioned> ;
+: Wb ( n -- weber ) { m m kg } { s s A } <dimensioned> ;
+: T ( n -- tesla ) { kg } { s s A } <dimensioned> ;
+: H ( n -- henry ) { m m kg } { s s A A } <dimensioned> ;
+: deg-C ( n -- Celsius ) 27315/100 + { K } { } <dimensioned> ;
+: lm ( n -- lumen ) { m m cd } { m m } <dimensioned> ;
+: lx ( n -- lux ) { m m cd } { m m m m } <dimensioned> ;
+: Bq ( n -- becquerel ) { } { s } <dimensioned> ;
+: Gy ( n -- gray ) { m m } { s s } <dimensioned> ;
+: Sv ( n -- sievert ) { m m } { s s } <dimensioned> ;
+: kat ( n -- katal ) { mol } { s } <dimensioned> ;
+
+! 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 ) { } { } <dimensioned> ;
+: 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 } <dimensioned> ;
+: 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 ;
--- /dev/null
+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 { } { } <dimensioned> = ] 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 } <dimensioned> = ] unit-test
+
+: km/L km 1 L d/ ;
+: mpg miles 1 gallons d/ ;
+
+[ t ] [ 100 10 / km/L [ mpg ] undo 23 1 ~ ] unit-test
--- /dev/null
+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 ;
+
+: <dimensioned> ( n top bot -- obj )
+ symbolic-reduce
+ [ natural-sort ] bi@
+ dimensioned boa ;
+
+: >dimensioned< ( d -- n top bot )
+ [ value>> ] [ top>> ] [ bot>> ] tri ;
+
+\ <dimensioned> [ >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@ ;
+
+: <dimension-op ( dim dim -- top bot val val )
+ 2dup check-dimensions dup dimensions 2swap 2values ;
+
+: dimension-op> ( top bot val -- dim )
+ -rot <dimensioned> ;
+
+: d+ ( d d -- d ) <dimension-op + dimension-op> ;
+
+: d- ( d d -- d ) <dimension-op - dimension-op> ;
+
+: scalar ( n -- d )
+ { } { } <dimensioned> ;
+
+: 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
<head>
<t:write-title />
- <t:style t:include="resource:extra/xmode/code2html/stylesheet.css" />
+ <t:style t:include="resource:basis/xmode/code2html/stylesheet.css" />
<t:style t:include="resource:extra/websites/concatenative/page.css" />
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
--- /dev/null
+! 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 <name> ] [ <simple-name> ] 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 <xml> ;
+
+DEFER: XML>
+
+: <XML
+ \ XML> [ >quotation ] parse-literal
+ { } parsed \ make parsed \ >xml-document parsed ; parsing
USING: compiler continuations io kernel math namespaces
prettyprint quotations random sequences vectors
compiler.units ;
-USING: random-tester.databank random-tester.safe-words ;
+USING: random-tester.databank random-tester.safe-words
+random-tester.random ;
IN: random-tester
SYMBOL: errored
: setup-test ( #data #code -- data... quot )
#! Variable stack effect
>r [ databank random ] times r>
+ ! 200 300 random-cond ;
+ ! random-if ;
[ drop \ safe-words get random ] map >quotation ;
: test-compiler ! ( data... quot -- ... )
USING: kernel math sequences namespaces hashtables words
-arrays parser compiler syntax io prettyprint optimizer
-random math.constants math.functions layouts random-tester.utils ;
+arrays parser compiler syntax io prettyprint random
+math.constants math.functions layouts random-tester.utils
+random-tester.safe-words quotations fry combinators ;
IN: random-tester
! Tweak me
: random-complex ( -- C )
random-number random-number rect> ;
+: random-quot ( n -- quot )
+ [ \ safe-words get random ] replicate >quotation ;
+
+: random-if ( n -- quot )
+ [ random-quot ] [ random-quot ] bi
+ '[ , , if ] ;
+
+: random-cond ( m n -- quot )
+ [ '[ , [ random-quot ] [ random-quot ] bi 2array ] replicate ]
+ [ random-quot ] bi suffix
+ '[ , cond ] ;
: ?-words
{
- delegate
-
/f
bits>float bits>double
projects / factor.git / commitdiff