dup 1 -> setResolvesAliases:
dup 1 -> setAllowsMultipleSelection: ;
+: <NSDirPanel> ( -- panel ) <NSOpenPanel>
+ dup 1 -> setCanChooseDirectories: ;
+
: <NSSavePanel> ( -- panel )
NSSavePanel -> savePanel
dup 1 -> setCanChooseFiles:
CONSTANT: NSOKButton 1
CONSTANT: NSCancelButton 0
-: open-panel ( -- paths )
- <NSOpenPanel>
+: (open-panel) ( panel -- paths )
dup -> runModal NSOKButton =
[ -> filenames CF>string-array ] [ drop f ] if ;
+
+: open-panel ( -- paths ) <NSOpenPanel> (open-panel) ;
+: open-dir-panel ( -- paths ) <NSDirPanel> (open-panel) ;
: split-path ( path -- dir file )
"/" split1-last [ <NSString> ] bi@ ;
-USING: help.syntax help.markup ;
+USING: help.syntax help.markup ui.pixel-formats ;
IN: cocoa.views
-HELP: <PixelFormat>
-{ $values { "attributes" "a sequence of attributes" } { "pixelfmt" "an " { $snippet "NSOpenGLPixelFormat" } } }
-{ $description "Creates an " { $snippet "NSOpenGLPixelFormat" } " with some reasonable defaults." } ;
-
HELP: <GLView>
-{ $values { "class" "an subclass of " { $snippet "NSOpenGLView" } } { "dim" "a pair of real numbers" } { "view" "a new " { $snippet "NSOpenGLView" } } }
-{ $description "Creates a new instance of the specified class, giving it a default pixel format and the given size." } ;
+{ $values { "class" "an subclass of " { $snippet "NSOpenGLView" } } { "dim" "a pair of real numbers" } { "pixel-format" pixel-format } { "view" "a new " { $snippet "NSOpenGLView" } } }
+{ $description "Creates a new instance of the specified class, giving it the specified pixel format and size." } ;
HELP: view-dim
{ $values { "view" "an " { $snippet "NSView" } } { "dim" "a pair of real numbers" } }
{ $description "Outputs the current mouse location." } ;
ARTICLE: "cocoa-view-utils" "Cocoa view utilities"
-{ $subsection <PixelFormat> }
{ $subsection <GLView> }
{ $subsection view-dim }
{ $subsection mouse-location } ;
CONSTANT: NSOpenGLPFAVirtualScreenCount 128
CONSTANT: NSOpenGLCPSwapInterval 222
-<PRIVATE
-
-SYMBOL: software-renderer?
-SYMBOL: multisample?
-
-PRIVATE>
-
-: with-software-renderer ( quot -- )
- [ t software-renderer? ] dip with-variable ; inline
-
-: with-multisample ( quot -- )
- [ t multisample? ] dip with-variable ; inline
-
-: <PixelFormat> ( attributes -- pixelfmt )
- NSOpenGLPixelFormat -> alloc swap [
- %
- NSOpenGLPFADepthSize , 16 ,
- software-renderer? get [
- NSOpenGLPFARendererID , kCGLRendererGenericFloatID ,
- ] when
- multisample? get [
- NSOpenGLPFASupersample ,
- NSOpenGLPFASampleBuffers , 1 ,
- NSOpenGLPFASamples , 8 ,
- ] when
- 0 ,
- ] int-array{ } make
- -> initWithAttributes:
- -> autorelease ;
-
-: <GLView> ( class dim -- view )
- [ -> alloc 0 0 ] dip first2 <CGRect>
- NSOpenGLPFAWindow NSOpenGLPFADoubleBuffer 2array <PixelFormat>
+: <GLView> ( class dim pixel-format -- view )
+ [ -> alloc ]
+ [ [ 0 0 ] dip first2 <CGRect> ]
+ [ handle>> ] tri*
-> initWithFrame:pixelFormat:
dup 1 -> setPostsBoundsChangedNotifications:
dup 1 -> setPostsFrameChangedNotifications: ;
HELP: SLOT-PROTOCOL:
{ $syntax "SLOT-PROTOCOL: protocol-name slots... ;" }
-{ $description "Defines a protocol consisting of reader and writer words for the listen slot names." } ;
+{ $description "Defines a protocol consisting of reader and writer words for the listed slot names." } ;
{ define-protocol POSTPONE: PROTOCOL: } related-words
USING: accessors arrays ascii assocs calendar combinators fry kernel
generalizations io io.encodings.ascii io.files io.streams.string
macros math math.functions math.parser peg.ebnf quotations
-sequences splitting strings unicode.case vectors ;
+sequences splitting strings unicode.case vectors combinators.smart ;
IN: formatting
: sprintf ( format-string -- result )
[ printf ] with-string-writer ; inline
-
<PRIVATE
: pad-00 ( n -- string ) number>string 2 CHAR: 0 pad-head ; inline
[ pad-00 ] map "/" join ; inline
: >datetime ( timestamp -- string )
- { [ day-of-week day-abbreviation3 ]
- [ month>> month-abbreviation ]
- [ day>> pad-00 ]
- [ >time ]
- [ year>> number>string ]
- } cleave 5 narray " " join ; inline
+ [
+ {
+ [ day-of-week day-abbreviation3 ]
+ [ month>> month-abbreviation ]
+ [ day>> pad-00 ]
+ [ >time ]
+ [ year>> number>string ]
+ } cleave
+ ] output>array " " join ; inline
: (week-of-year) ( timestamp day -- n )
[ dup clone 1 >>month 1 >>day day-of-week dup ] dip > [ 7 swap - ] when
MACRO: strftime ( format-string -- )
parse-strftime [ length ] keep [ ] join
'[ _ <vector> @ reverse concat nip ] ;
-
-
: list ( url -- ftp-response )
utf8 open-passive-client
ftp-list
- lines
+ stream-lines
<ftp-response> swap >>strings
read-response 226 ftp-assert
parse-list ;
[ blorgh ] [ blorgh ] unit-test
-GENERIC: some-generic ( a -- b )
+<<
+
+FUNCTOR: generic-test ( W -- )
+
+W DEFINES ${W}
+
+WHERE
+
+GENERIC: W ( a -- b )
+M: object W ;
+M: integer W 1 + ;
+
+;FUNCTOR
+
+"snurv" generic-test
+
+>>
+
+[ 2 ] [ 1 snurv ] unit-test
+[ 3.0 ] [ 3.0 snurv ] unit-test
! Does replacing an ordinary word with a functor-generated one work?
[ [ ] ] [
TUPLE: some-tuple ;
: some-word ( -- ) ;
+ GENERIC: some-generic ( a -- b )
M: some-tuple some-generic ;
SYMBOL: some-symbol
"> <string-reader> "functors-test" parse-stream
: test-redefinition ( -- )
[ t ] [ "some-word" "functors.tests" lookup >boolean ] unit-test
[ t ] [ "some-tuple" "functors.tests" lookup >boolean ] unit-test
+ [ t ] [ "some-generic" "functors.tests" lookup >boolean ] unit-test
[ t ] [
"some-tuple" "functors.tests" lookup
"some-generic" "functors.tests" lookup method >boolean
W-word DEFINES ${W}-word
W-tuple DEFINES-CLASS ${W}-tuple
-W-generic IS ${W}-generic
+W-generic DEFINES ${W}-generic
W-symbol DEFINES ${W}-symbol
WHERE
TUPLE: W-tuple ;
: W-word ( -- ) ;
+GENERIC: W-generic ( a -- b )
M: W-tuple W-generic ;
SYMBOL: W-symbol
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel quotations classes.tuple make combinators generic
-words interpolate namespaces sequences io.streams.string fry
-classes.mixin effects lexer parser classes.tuple.parser
-effects.parser locals.types locals.parser generic.parser
-locals.rewrite.closures vocabs.parser classes.parser
-arrays accessors words.symbol ;
+USING: accessors arrays classes.mixin classes.parser
+classes.tuple classes.tuple.parser combinators effects
+effects.parser fry generic generic.parser generic.standard
+interpolate io.streams.string kernel lexer locals.parser
+locals.rewrite.closures locals.types make namespaces parser
+quotations sequences vocabs.parser words words.symbol ;
IN: functors
! This is a hack
: define-declared* ( word def effect -- ) pick set-word define-declared ;
+: define-simple-generic* ( word effect -- ) over set-word define-simple-generic ;
+
TUPLE: fake-call-next-method ;
TUPLE: fake-quotation seq ;
scan-param parsed
\ add-mixin-instance parsed ;
+SYNTAX: `GENERIC:
+ scan-param parsed
+ complete-effect parsed
+ \ define-simple-generic* parsed ;
+
SYNTAX: `inline [ word make-inline ] over push-all ;
SYNTAX: `call-next-method T{ fake-call-next-method } parsed ;
{ "M:" POSTPONE: `M: }
{ "C:" POSTPONE: `C: }
{ ":" POSTPONE: `: }
+ { "GENERIC:" POSTPONE: `GENERIC: }
{ "INSTANCE:" POSTPONE: `INSTANCE: }
{ "SYNTAX:" POSTPONE: `SYNTAX: }
{ "SYMBOL:" POSTPONE: `SYMBOL: }
+! Copyright (C) 2007, 2009 Daniel Ehrenberg.
+! See http://factorcode.org/license.txt for BSD license.
USING: inverse tools.test arrays math kernel sequences
-math.functions math.constants continuations ;
+math.functions math.constants continuations combinators.smart ;
IN: inverse-tests
[ 2 ] [ { 3 2 } [ 3 swap 2array ] undo ] unit-test
[ t ] [ pi [ pi ] matches? ] unit-test
[ 0.0 ] [ 0.0 pi + [ pi + ] undo ] unit-test
-[ ] [ 3 [ _ ] undo ] unit-test
+[ ] [ 3 [ __ ] undo ] unit-test
[ 2.0 ] [ 2 3 ^ [ 3 ^ ] undo ] unit-test
[ 3.0 ] [ 2 3 ^ [ 2 swap ^ ] undo ] unit-test
: <funny-tuple> ( -- funny-tuple ) \ funny-tuple boa ;
: funny-tuple ( -- ) "OOPS" throw ;
-[ ] [ [ <funny-tuple> ] [undo] drop ] unit-test
\ No newline at end of file
+[ ] [ [ <funny-tuple> ] [undo] drop ] unit-test
+
+[ 0 ] [ { 1 2 } [ [ 1+ 2 ] { } output>sequence ] undo ] unit-test
+[ { 0 1 } ] [ 1 2 [ [ [ 1+ ] bi@ ] input<sequence ] undo ] unit-test
-! Copyright (C) 2007, 2008 Daniel Ehrenberg.
+! Copyright (C) 2007, 2009 Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel words summary slots quotations
sequences assocs math arrays stack-checker effects generalizations
continuations debugger classes.tuple namespaces make vectors
bit-arrays byte-arrays strings sbufs math.functions macros
-sequences.private combinators mirrors splitting
-combinators.short-circuit fry words.symbol generalizations ;
-RENAME: _ fry => __
+sequences.private combinators mirrors splitting combinators.smart
+combinators.short-circuit fry words.symbol generalizations
+classes ;
IN: inverse
ERROR: fail ;
: assure ( ? -- ) [ fail ] unless ; inline
-: =/fail ( obj1 obj2 -- ) = assure ;
+: =/fail ( obj1 obj2 -- ) = assure ; inline
! Inverse of a quotation
\ pick [ [ pick ] dip =/fail ] define-inverse
\ tuck [ swapd [ =/fail ] keep ] define-inverse
+\ bi@ 1 [ [undo] '[ _ bi@ ] ] define-pop-inverse
+\ tri@ 1 [ [undo] '[ _ tri@ ] ] define-pop-inverse
+\ bi* 2 [ [ [undo] ] bi@ '[ _ _ bi* ] ] define-pop-inverse
+\ tri* 3 [ [ [undo] ] tri@ '[ _ _ _ tri* ] ] define-pop-inverse
+
\ not define-involution
-\ >boolean [ { t f } memq? assure ] define-inverse
+\ >boolean [ dup { t f } memq? assure ] define-inverse
\ tuple>array \ >tuple define-dual
\ reverse define-involution
-\ undo 1 [ [ call ] curry ] define-pop-inverse
-\ map 1 [ [undo] [ over sequence? assure map ] curry ] define-pop-inverse
+\ undo 1 [ ] define-pop-inverse
+\ map 1 [ [undo] '[ dup sequence? assure _ map ] ] define-pop-inverse
\ exp \ log define-dual
\ sq \ sqrt define-dual
2curry
] define-pop-inverse
-DEFER: _
-\ _ [ drop ] define-inverse
+DEFER: __
+\ __ [ drop ] define-inverse
: both ( object object -- object )
dupd assert= ;
\ both [ dup ] define-inverse
-: assure-length ( seq length -- seq )
- over length =/fail ;
-
{
{ >array array? }
{ >vector vector? }
{ >string string? }
{ >sbuf sbuf? }
{ >quotation quotation? }
-} [ \ dup swap \ assure 3array >quotation define-inverse ] assoc-each
+} [ '[ dup _ execute assure ] define-inverse ] assoc-each
+
+: assure-length ( seq length -- )
+ swap length =/fail ; inline
+
+: assure-array ( array -- array )
+ dup array? assure ; inline
-! These actually work on all seqs--should they?
-\ 1array [ 1 assure-length first ] define-inverse
-\ 2array [ 2 assure-length first2 ] define-inverse
-\ 3array [ 3 assure-length first3 ] define-inverse
-\ 4array [ 4 assure-length first4 ] define-inverse
-\ narray 1 [ [ firstn ] curry ] define-pop-inverse
+: undo-narray ( array n -- ... )
+ [ assure-array ] dip
+ [ assure-length ] [ firstn ] 2bi ; inline
+
+\ 1array [ 1 undo-narray ] define-inverse
+\ 2array [ 2 undo-narray ] define-inverse
+\ 3array [ 3 undo-narray ] define-inverse
+\ 4array [ 4 undo-narray ] define-inverse
+\ narray 1 [ '[ _ undo-narray ] ] define-pop-inverse
\ first [ 1array ] define-inverse
\ first2 [ 2array ] define-inverse
\ append 1 [ [ ?tail assure ] curry ] define-pop-inverse
\ prepend 1 [ [ ?head assure ] curry ] define-pop-inverse
+: assure-same-class ( obj1 obj2 -- )
+ [ class ] bi@ = assure ; inline
+
+\ output>sequence 2 [ [undo] '[ dup _ assure-same-class _ input<sequence ] ] define-pop-inverse
+\ input<sequence 1 [ [undo] '[ _ { } output>sequence ] ] define-pop-inverse
+
! Constructor inverse
: deconstruct-pred ( class -- quot )
"predicate" word-prop [ dupd call assure ] curry ;
] recover ; inline
: true-out ( quot effect -- quot' )
- out>> '[ @ __ ndrop t ] ;
+ out>> '[ @ _ ndrop t ] ;
: false-recover ( effect -- quot )
in>> [ ndrop f ] curry [ recover-fail ] curry ;
IN: io.encodings.string
: decode ( byte-array encoding -- string )
- <byte-reader> contents ;
+ <byte-reader> stream-contents ;
: encode ( string encoding -- byte-array )
[ write ] with-byte-writer ;
USING: system kernel namespaces strings hashtables sequences
assocs combinators vocabs.loader init threads continuations
math accessors concurrency.flags destructors environment
-io io.backend io.timeouts io.pipes io.pipes.private io.encodings
-io.streams.duplex io.ports debugger prettyprint summary
-calendar ;
+io io.encodings.ascii io.backend io.timeouts io.pipes
+io.pipes.private io.encodings io.streams.duplex io.ports
+debugger prettyprint summary calendar ;
IN: io.launcher
TUPLE: process < identity-tuple
{ [ os winnt? ] [ "io.launcher.windows.nt" require ] }
[ ]
} cond
+
+: run-desc ( desc -- result ) ascii <process-reader> f swap stream-read-until drop ;
"cat"
"launcher-test-1" temp-file
2array
- ascii <process-reader> contents
+ ascii <process-reader> stream-contents
] unit-test
[ ] [
"cat"
"launcher-test-1" temp-file
2array
- ascii <process-reader> contents
+ ascii <process-reader> stream-contents
] unit-test
[ ] [
"cat"
"launcher-test-1" temp-file
2array
- ascii <process-reader> contents
+ ascii <process-reader> stream-contents
] unit-test
[ t ] [
<process>
"env" >>command
{ { "A" "B" } } >>environment
- ascii <process-reader> lines
+ ascii <process-reader> stream-lines
"A=B" swap member?
] unit-test
"env" >>command
{ { "A" "B" } } >>environment
+replace-environment+ >>environment-mode
- ascii <process-reader> lines
+ ascii <process-reader> stream-lines
] unit-test
[ "hi\n" ] [
"append-test" temp-file utf8 file-contents
] unit-test
-[ t ] [ "ls" utf8 <process-stream> contents >boolean ] unit-test
+[ t ] [ "ls" utf8 <process-stream> stream-contents >boolean ] unit-test
[ "Hello world.\n" ] [
"cat" utf8 <process-stream> [
"Hello world.\n" write
output-stream get dispose
- input-stream get contents
+ input-stream get stream-contents
] with-stream
] unit-test
dup start-server* sockets>> first addr>> port>> "port" set
] unit-test
-[ "Hello world." ] [ "localhost" "port" get <inet> ascii <client> drop contents ] unit-test
+[ "Hello world." ] [ "localhost" "port" get <inet> ascii <client> drop stream-contents ] unit-test
: client-test ( -- string )
<secure-config> [
- "127.0.0.1" "port" get ?promise <inet4> <secure> ascii <client> drop contents
+ "127.0.0.1" "port" get ?promise <inet4> <secure> ascii <client> drop stream-contents
] with-secure-context ;
[ ] [ [ class name>> write ] server-test ] unit-test
--- /dev/null
+! Copyright (C) 2008 Joe Groff.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax kernel multiline ;
+IN: literals
+
+HELP: $
+{ $syntax "$ word" }
+{ $description "Executes " { $snippet "word" } " at parse time and adds the result(s) to the parser accumulator." }
+{ $notes { $snippet "word" } "'s definition is looked up and " { $link call } "ed at parse time, so words that reference words in the current compilation unit cannot be used with " { $snippet "$" } "." }
+{ $examples
+
+ { $example <"
+USING: kernel literals prettyprint ;
+IN: scratchpad
+
+CONSTANT: five 5
+{ $ five } .
+ "> "{ 5 }" }
+
+ { $example <"
+USING: kernel literals prettyprint ;
+IN: scratchpad
+
+<< : seven-eleven ( -- a b ) 7 11 ; >>
+{ $ seven-eleven } .
+ "> "{ 7 11 }" }
+
+} ;
+
+HELP: $[
+{ $syntax "$[ code ]" }
+{ $description "Calls " { $snippet "code" } " at parse time and adds the result(s) to the parser accumulator." }
+{ $notes "Since " { $snippet "code" } " is " { $link call } "ed at parse time, it cannot reference any words defined in the same compilation unit." }
+{ $examples
+
+ { $example <"
+USING: kernel literals math prettyprint ;
+IN: scratchpad
+
+<< CONSTANT: five 5 >>
+{ $[ five dup 1+ dup 2 + ] } .
+ "> "{ 5 6 8 }" }
+
+} ;
+
+{ POSTPONE: $ POSTPONE: $[ } related-words
+
+ARTICLE: "literals" "Interpolating code results into literal values"
+"The " { $vocab-link "literals" } " vocabulary contains words to run code at parse time and insert the results into more complex literal values."
+{ $example <"
+USING: kernel literals math prettyprint ;
+IN: scratchpad
+
+<< CONSTANT: five 5 >>
+{ $ five $[ five dup 1+ dup 2 + ] } .
+ "> "{ 5 5 6 8 }" }
+{ $subsection POSTPONE: $ }
+{ $subsection POSTPONE: $[ }
+;
+
+ABOUT: "literals"
--- /dev/null
+USING: kernel literals math tools.test ;
+IN: literals.tests
+
+<<
+: six-six-six ( -- a b c ) 6 6 6 ;
+>>
+
+: five ( -- a ) 5 ;
+: seven-eleven ( -- b c ) 7 11 ;
+
+[ { 5 } ] [ { $ five } ] unit-test
+[ { 7 11 } ] [ { $ seven-eleven } ] unit-test
+[ { 6 6 6 } ] [ { $ six-six-six } ] unit-test
+
+[ { 6 6 6 7 } ] [ { $ six-six-six 7 } ] unit-test
+
+[ { 8 8 8 } ] [ { $[ six-six-six [ 2 + ] tri@ ] } ] unit-test
+
+[ { 0.5 2.0 } ] [ { $[ 1.0 2.0 / ] 2.0 } ] unit-test
+
+[ { 1.0 { 0.5 1.5 } 4.0 } ] [ { 1.0 { $[ 1.0 2.0 / ] 1.5 } $[ 2.0 2.0 * ] } ] unit-test
+
+<<
+CONSTANT: constant-a 3
+>>
+
+[ { 3 10 "ftw" } ] [ ${ constant-a 10 "ftw" } ] unit-test
--- /dev/null
+! (c) Joe Groff, see license for details
+USING: accessors continuations kernel parser words quotations
+combinators.smart vectors sequences ;
+IN: literals
+
+SYNTAX: $ scan-word [ def>> call ] curry with-datastack >vector ;
+SYNTAX: $[ parse-quotation with-datastack >vector ;
+SYNTAX: ${ \ } [ [ ?execute ] { } map-as ] parse-literal ;
--- /dev/null
+Expression interpolation into sequence literals
--- /dev/null
+extensions
+syntax
USING: tools.test math.rectangles ;
IN: math.rectangles.tests
-[ T{ rect f { 10 10 } { 20 20 } } ]
+[ RECT: { 10 10 } { 20 20 } ]
[
- T{ rect f { 10 10 } { 50 50 } }
- T{ rect f { -10 -10 } { 40 40 } }
+ RECT: { 10 10 } { 50 50 }
+ RECT: { -10 -10 } { 40 40 }
rect-intersect
] unit-test
-[ T{ rect f { 200 200 } { 0 0 } } ]
+[ RECT: { 200 200 } { 0 0 } ]
[
- T{ rect f { 100 100 } { 50 50 } }
- T{ rect f { 200 200 } { 40 40 } }
+ RECT: { 100 100 } { 50 50 }
+ RECT: { 200 200 } { 40 40 }
rect-intersect
] unit-test
[ f ] [
- T{ rect f { 100 100 } { 50 50 } }
- T{ rect f { 200 200 } { 40 40 } }
+ RECT: { 100 100 } { 50 50 }
+ RECT: { 200 200 } { 40 40 }
contains-rect?
] unit-test
[ t ] [
- T{ rect f { 100 100 } { 50 50 } }
- T{ rect f { 120 120 } { 40 40 } }
+ RECT: { 100 100 } { 50 50 }
+ RECT: { 120 120 } { 40 40 }
contains-rect?
] unit-test
[ f ] [
- T{ rect f { 1000 100 } { 50 50 } }
- T{ rect f { 120 120 } { 40 40 } }
+ RECT: { 1000 100 } { 50 50 }
+ RECT: { 120 120 } { 40 40 }
contains-rect?
] unit-test
-[ T{ rect f { 10 20 } { 20 20 } } ] [
+[ RECT: { 10 20 } { 20 20 } ] [
{
{ 20 20 }
{ 10 40 }
{ 30 30 }
} rect-containing
-] unit-test
\ No newline at end of file
+] unit-test
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel arrays sequences math math.vectors accessors ;
+USING: kernel arrays sequences math math.vectors accessors
+parser prettyprint.custom prettyprint.backend ;
IN: math.rectangles
TUPLE: rect { loc initial: { 0 0 } } { dim initial: { 0 0 } } ;
: <rect> ( loc dim -- rect ) rect boa ; inline
+SYNTAX: RECT: scan-object scan-object <rect> parsed ;
+
+M: rect pprint*
+ \ RECT: [ [ loc>> ] [ dim>> ] bi [ pprint* ] bi@ ] pprint-prefix ;
+
: <zero-rect> ( -- rect ) rect new ; inline
: point>rect ( loc -- rect ) { 0 0 } <rect> ; inline
: set-rect-bounds ( rect1 rect -- )
[ [ loc>> ] dip (>>loc) ]
[ [ dim>> ] dip (>>dim) ]
- 2bi ; inline
\ No newline at end of file
+ 2bi ; inline
-USING: kernel windows.opengl32 ;
+USING: alien.syntax kernel windows.types ;
IN: opengl.gl.windows
+LIBRARY: gl
+
+FUNCTION: HGLRC wglGetCurrentContext ( ) ;
+FUNCTION: void* wglGetProcAddress ( char* name ) ;
+
: gl-function-context ( -- context ) wglGetCurrentContext ; inline
: gl-function-address ( name -- address ) wglGetProcAddress ; inline
: gl-function-calling-convention ( -- str ) "stdcall" ; inline
[ text ] [ f <inset pprint* block> ] bi*
\ } pprint-word block> ;
-M: tuple pprint*
- boa-tuples? get [ call-next-method ] [
+: pprint-tuple ( tuple -- )
+ boa-tuples? get [ pprint-object ] [
[
<flow
\ T{ pprint-word
] check-recursion
] if ;
+M: tuple pprint*
+ pprint-tuple ;
+
: do-length-limit ( seq -- trimmed n/f )
length-limit get dup [
over length over [-]
: randomize ( seq -- seq )
dup length [ dup 1 > ]
- [ [ random ] [ 1- ] bi [ pick exchange ] keep ]
+ [ [ iota random ] [ 1- ] bi [ pick exchange ] keep ]
while drop ;
: delete-random ( seq -- elt )
! Copyright (C) 2006, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors math arrays assocs cocoa cocoa.application
-command-line kernel memory namespaces cocoa.messages
-cocoa.runtime cocoa.subclassing cocoa.pasteboard cocoa.types
-cocoa.windows cocoa.classes cocoa.nibs sequences ui ui.private
-ui.backend ui.clipboards ui.gadgets ui.gadgets.worlds
-ui.backend.cocoa.views core-foundation core-foundation.run-loop
-core-graphics.types threads math.rectangles fry libc
-generalizations alien.c-types cocoa.views
-combinators io.thread locals ;
+USING: accessors alien.c-types arrays assocs classes cocoa
+cocoa.application cocoa.classes cocoa.messages cocoa.nibs
+cocoa.pasteboard cocoa.runtime cocoa.subclassing cocoa.types
+cocoa.views cocoa.windows combinators command-line
+core-foundation core-foundation.run-loop core-graphics
+core-graphics.types destructors fry generalizations io.thread
+kernel libc literals locals math math.rectangles memory
+namespaces sequences specialized-arrays.int threads ui
+ui.backend ui.backend.cocoa.views ui.clipboards ui.gadgets
+ui.gadgets.worlds ui.pixel-formats ui.pixel-formats.private
+ui.private words.symbol ;
IN: ui.backend.cocoa
TUPLE: handle ;
SINGLETON: cocoa-ui-backend
+PIXEL-FORMAT-ATTRIBUTE-TABLE: NSOpenGLPFA { } H{
+ { double-buffered { $ NSOpenGLPFADoubleBuffer } }
+ { stereo { $ NSOpenGLPFAStereo } }
+ { offscreen { $ NSOpenGLPFAOffScreen } }
+ { fullscreen { $ NSOpenGLPFAFullScreen } }
+ { windowed { $ NSOpenGLPFAWindow } }
+ { accelerated { $ NSOpenGLPFAAccelerated } }
+ { software-rendered { $ NSOpenGLPFASingleRenderer $ kCGLRendererGenericFloatID } }
+ { backing-store { $ NSOpenGLPFABackingStore } }
+ { multisampled { $ NSOpenGLPFAMultisample } }
+ { supersampled { $ NSOpenGLPFASupersample } }
+ { sample-alpha { $ NSOpenGLPFASampleAlpha } }
+ { color-float { $ NSOpenGLPFAColorFloat } }
+ { color-bits { $ NSOpenGLPFAColorSize } }
+ { alpha-bits { $ NSOpenGLPFAAlphaSize } }
+ { accum-bits { $ NSOpenGLPFAAccumSize } }
+ { depth-bits { $ NSOpenGLPFADepthSize } }
+ { stencil-bits { $ NSOpenGLPFAStencilSize } }
+ { aux-buffers { $ NSOpenGLPFAAuxBuffers } }
+ { sample-buffers { $ NSOpenGLPFASampleBuffers } }
+ { samples { $ NSOpenGLPFASamples } }
+}
+
+M: cocoa-ui-backend (make-pixel-format)
+ nip >NSOpenGLPFA-int-array
+ NSOpenGLPixelFormat -> alloc swap -> initWithAttributes: ;
+
+M: cocoa-ui-backend (free-pixel-format)
+ handle>> -> release ;
+
+M: cocoa-ui-backend (pixel-format-attribute)
+ [ handle>> ] [ >NSOpenGLPFA ] bi*
+ [ drop f ]
+ [ first 0 <int> [ swap 0 -> getValues:forAttribute:forVirtualScreen: ] keep *int ]
+ if-empty ;
+
TUPLE: pasteboard handle ;
C: <pasteboard> pasteboard
handle>> view>> -> isInFullScreenMode zero? not ;
M:: cocoa-ui-backend (open-window) ( world -- )
- world dim>> <FactorView> :> view
+ world [ [ dim>> ] dip <FactorView> ]
+ with-world-pixel-format :> view
view world world>NSRect <ViewWindow> :> window
view -> release
world view register-window
] when* ;
: pixel-size ( pixel-format -- size )
- 0 <int> [ NSOpenGLPFAColorSize 0 -> getValues:forAttribute:forVirtualScreen: ]
- keep *int -3 shift ;
+ color-bits pixel-format-attribute -3 shift ;
: offscreen-buffer ( world pixel-format -- alien w h pitch )
[ dim>> first2 ] [ pixel-size ] bi*
{ [ * * malloc ] [ 2drop ] [ drop nip ] [ nip * ] } 3cleave ;
-: gadget-offscreen-context ( world -- context buffer )
- NSOpenGLPFAOffScreen 1array <PixelFormat>
- [ nip NSOpenGLContext -> alloc swap f -> initWithFormat:shareContext: dup ]
- [ offscreen-buffer ] 2bi
- 4 npick [ -> setOffScreen:width:height:rowbytes: ] dip ;
+:: gadget-offscreen-context ( world -- context buffer )
+ world [
+ nip :> pf
+ NSOpenGLContext -> alloc pf handle>> f -> initWithFormat:shareContext:
+ dup world pf offscreen-buffer
+ 4 npick [ -> setOffScreen:width:height:rowbytes: ] dip
+ ] with-world-pixel-format ;
M: cocoa-ui-backend (open-offscreen-buffer) ( world -- )
dup gadget-offscreen-context <offscreen-handle> >>handle drop ;
IN: ui.backend.cocoa.views
: send-mouse-moved ( view event -- )
- [ mouse-location ] [ drop window ] 2bi move-hand fire-motion ;
+ [ mouse-location ] [ drop window ] 2bi move-hand fire-motion yield ;
: button ( event -- n )
#! Cocoa -> Factor UI button mapping
-> openGLContext -> CGLContextObj NSOpenGLCPSwapInterval 1 <int>
CGLSetParameter drop ;
-: <FactorView> ( dim -- view )
- FactorView swap <GLView> [ sync-refresh-to-screen ] keep ;
+: <FactorView> ( dim pixel-format -- view )
+ [ FactorView ] 2dip <GLView> [ sync-refresh-to-screen ] keep ;
: save-position ( world window -- )
-> frame CGRect-top-left 2array >>window-loc drop ;
threads libc combinators fry combinators.short-circuit continuations
command-line shuffle opengl ui.render ascii math.bitwise locals
accessors math.rectangles math.order ascii calendar
-io.encodings.utf16n windows.errors ;
+io.encodings.utf16n windows.errors literals ui.pixel-formats
+ui.pixel-formats.private memoize classes ;
IN: ui.backend.windows
SINGLETON: windows-ui-backend
+TUPLE: win-base hDC hRC ;
+TUPLE: win < win-base hWnd world title ;
+TUPLE: win-offscreen < win-base hBitmap bits ;
+C: <win> win
+C: <win-offscreen> win-offscreen
+
+<PRIVATE
+
+PIXEL-FORMAT-ATTRIBUTE-TABLE: WGL_ARB { $ WGL_SUPPORT_OPENGL_ARB 1 } H{
+ { double-buffered { $ WGL_DOUBLE_BUFFER_ARB 1 } }
+ { stereo { $ WGL_STEREO_ARB 1 } }
+ { offscreen { $ WGL_DRAW_TO_BITMAP_ARB 1 } }
+ { fullscreen { $ WGL_DRAW_TO_WINDOW_ARB 1 } }
+ { windowed { $ WGL_DRAW_TO_WINDOW_ARB 1 } }
+ { accelerated { $ WGL_ACCELERATION_ARB $ WGL_FULL_ACCELERATION_ARB } }
+ { software-rendered { $ WGL_ACCELERATION_ARB $ WGL_NO_ACCELERATION_ARB } }
+ { backing-store { $ WGL_SWAP_METHOD_ARB $ WGL_SWAP_COPY_ARB } }
+ { color-float { $ WGL_TYPE_RGBA_FLOAT_ARB 1 } }
+ { color-bits { $ WGL_COLOR_BITS_ARB } }
+ { red-bits { $ WGL_RED_BITS_ARB } }
+ { green-bits { $ WGL_GREEN_BITS_ARB } }
+ { blue-bits { $ WGL_BLUE_BITS_ARB } }
+ { alpha-bits { $ WGL_ALPHA_BITS_ARB } }
+ { accum-bits { $ WGL_ACCUM_BITS_ARB } }
+ { accum-red-bits { $ WGL_ACCUM_RED_BITS_ARB } }
+ { accum-green-bits { $ WGL_ACCUM_GREEN_BITS_ARB } }
+ { accum-blue-bits { $ WGL_ACCUM_BLUE_BITS_ARB } }
+ { accum-alpha-bits { $ WGL_ACCUM_ALPHA_BITS_ARB } }
+ { depth-bits { $ WGL_DEPTH_BITS_ARB } }
+ { stencil-bits { $ WGL_STENCIL_BITS_ARB } }
+ { aux-buffers { $ WGL_AUX_BUFFERS_ARB } }
+ { sample-buffers { $ WGL_SAMPLE_BUFFERS_ARB } }
+ { samples { $ WGL_SAMPLES_ARB } }
+}
+
+MEMO: (has-wglChoosePixelFormatARB?) ( dc -- ? )
+ { "WGL_ARB_pixel_format" } has-wgl-extensions? ;
+: has-wglChoosePixelFormatARB? ( world -- ? )
+ handle>> hDC>> (has-wglChoosePixelFormatARB?) ;
+
+: arb-make-pixel-format ( world attributes -- pf )
+ [ handle>> hDC>> ] dip >WGL_ARB-int-array f 1 0 <int> 0 <int>
+ [ wglChoosePixelFormatARB win32-error=0/f ] 2keep drop *int ;
+
+: arb-pixel-format-attribute ( pixel-format attribute -- value )
+ >WGL_ARB
+ [ drop f ] [
+ [ [ world>> handle>> hDC>> ] [ handle>> ] bi 0 1 ] dip
+ first <int> 0 <int>
+ [ wglGetPixelFormatAttribivARB win32-error=0/f ]
+ keep *int
+ ] if-empty ;
+
+CONSTANT: pfd-flag-map H{
+ { double-buffered $ PFD_DOUBLEBUFFER }
+ { stereo $ PFD_STEREO }
+ { offscreen $ PFD_DRAW_TO_BITMAP }
+ { fullscreen $ PFD_DRAW_TO_WINDOW }
+ { windowed $ PFD_DRAW_TO_WINDOW }
+ { backing-store $ PFD_SWAP_COPY }
+ { software-rendered $ PFD_GENERIC_FORMAT }
+}
+
+: >pfd-flag ( attribute -- value )
+ pfd-flag-map at [ ] [ 0 ] if* ;
+
+: >pfd-flags ( attributes -- flags )
+ [ >pfd-flag ] [ bitor ] map-reduce
+ PFD_SUPPORT_OPENGL bitor ;
+
+: attr-value ( attributes name -- value )
+ [ instance? ] curry find nip
+ [ value>> ] [ 0 ] if* ;
+
+: >pfd ( attributes -- pfd )
+ "PIXELFORMATDESCRIPTOR" <c-object>
+ "PIXELFORMATDESCRIPTOR" heap-size over set-PIXELFORMATDESCRIPTOR-nSize
+ 1 over set-PIXELFORMATDESCRIPTOR-nVersion
+ over >pfd-flags over set-PIXELFORMATDESCRIPTOR-dwFlags
+ PFD_TYPE_RGBA over set-PIXELFORMATDESCRIPTOR-iPixelType
+ over color-bits attr-value over set-PIXELFORMATDESCRIPTOR-cColorBits
+ over red-bits attr-value over set-PIXELFORMATDESCRIPTOR-cRedBits
+ over green-bits attr-value over set-PIXELFORMATDESCRIPTOR-cGreenBits
+ over blue-bits attr-value over set-PIXELFORMATDESCRIPTOR-cBlueBits
+ over alpha-bits attr-value over set-PIXELFORMATDESCRIPTOR-cAlphaBits
+ over accum-bits attr-value over set-PIXELFORMATDESCRIPTOR-cAccumBits
+ over accum-red-bits attr-value over set-PIXELFORMATDESCRIPTOR-cAccumRedBits
+ over accum-green-bits attr-value over set-PIXELFORMATDESCRIPTOR-cAccumGreenBits
+ over accum-blue-bits attr-value over set-PIXELFORMATDESCRIPTOR-cAccumBlueBits
+ over accum-alpha-bits attr-value over set-PIXELFORMATDESCRIPTOR-cAccumAlphaBits
+ over depth-bits attr-value over set-PIXELFORMATDESCRIPTOR-cDepthBits
+ over stencil-bits attr-value over set-PIXELFORMATDESCRIPTOR-cStencilBits
+ over aux-buffers attr-value over set-PIXELFORMATDESCRIPTOR-cAuxBuffers
+ PFD_MAIN_PLANE over set-PIXELFORMATDESCRIPTOR-dwLayerMask
+ nip ;
+
+: pfd-make-pixel-format ( world attributes -- pf )
+ [ handle>> hDC>> ] [ >pfd ] bi*
+ ChoosePixelFormat dup win32-error=0/f ;
+
+: get-pfd ( pixel-format -- pfd )
+ [ world>> handle>> hDC>> ] [ handle>> ] bi
+ "PIXELFORMATDESCRIPTOR" heap-size
+ "PIXELFORMATDESCRIPTOR" <c-object>
+ [ DescribePixelFormat win32-error=0/f ] keep ;
+
+: pfd-flag? ( pfd flag -- ? )
+ [ PIXELFORMATDESCRIPTOR-dwFlags ] dip bitand c-bool> ;
+
+: (pfd-pixel-format-attribute) ( pfd attribute -- value )
+ {
+ { double-buffered [ PFD_DOUBLEBUFFER pfd-flag? ] }
+ { stereo [ PFD_STEREO pfd-flag? ] }
+ { offscreen [ PFD_DRAW_TO_BITMAP pfd-flag? ] }
+ { fullscreen [ PFD_DRAW_TO_WINDOW pfd-flag? ] }
+ { windowed [ PFD_DRAW_TO_WINDOW pfd-flag? ] }
+ { software-rendered [ PFD_GENERIC_FORMAT pfd-flag? ] }
+ { color-bits [ PIXELFORMATDESCRIPTOR-cColorBits ] }
+ { red-bits [ PIXELFORMATDESCRIPTOR-cRedBits ] }
+ { green-bits [ PIXELFORMATDESCRIPTOR-cGreenBits ] }
+ { blue-bits [ PIXELFORMATDESCRIPTOR-cBlueBits ] }
+ { alpha-bits [ PIXELFORMATDESCRIPTOR-cAlphaBits ] }
+ { accum-bits [ PIXELFORMATDESCRIPTOR-cAccumBits ] }
+ { accum-red-bits [ PIXELFORMATDESCRIPTOR-cAccumRedBits ] }
+ { accum-green-bits [ PIXELFORMATDESCRIPTOR-cAccumGreenBits ] }
+ { accum-blue-bits [ PIXELFORMATDESCRIPTOR-cAccumBlueBits ] }
+ { accum-alpha-bits [ PIXELFORMATDESCRIPTOR-cAccumAlphaBits ] }
+ { depth-bits [ PIXELFORMATDESCRIPTOR-cDepthBits ] }
+ { stencil-bits [ PIXELFORMATDESCRIPTOR-cStencilBits ] }
+ { aux-buffers [ PIXELFORMATDESCRIPTOR-cAuxBuffers ] }
+ [ 2drop f ]
+ } case ;
+
+: pfd-pixel-format-attribute ( pixel-format attribute -- value )
+ [ get-pfd ] dip (pfd-pixel-format-attribute) ;
+
+M: windows-ui-backend (make-pixel-format)
+ over has-wglChoosePixelFormatARB?
+ [ arb-make-pixel-format ] [ pfd-make-pixel-format ] if ;
+
+M: windows-ui-backend (free-pixel-format)
+ drop ;
+
+M: windows-ui-backend (pixel-format-attribute)
+ over world>> has-wglChoosePixelFormatARB?
+ [ arb-pixel-format-attribute ] [ pfd-pixel-format-attribute ] if ;
+
+PRIVATE>
+
: lo-word ( wparam -- lo ) <short> *short ; inline
: hi-word ( wparam -- hi ) -16 shift lo-word ; inline
: >lo-hi ( WORD -- array ) [ lo-word ] [ hi-word ] bi 2array ;
<pasteboard> clipboard set-global
<clipboard> selection set-global ;
-TUPLE: win-base hDC hRC ;
-TUPLE: win < win-base hWnd world title ;
-TUPLE: win-offscreen < win-base hBitmap bits ;
-C: <win> win
-C: <win-offscreen> win-offscreen
-
SYMBOLS: msg-obj class-name-ptr mouse-captured ;
: style ( -- n ) WS_OVERLAPPEDWINDOW ; inline
f class-name-ptr set-global
f msg-obj set-global ;
-: setup-pixel-format ( hdc flags -- )
- 32 make-pfd [ ChoosePixelFormat dup win32-error=0/f ] 2keep
- swapd SetPixelFormat win32-error=0/f ;
+: get-dc ( world -- ) handle>> dup hWnd>> GetDC dup win32-error=0/f >>hDC drop ;
-: get-dc ( hWnd -- hDC ) GetDC dup win32-error=0/f ;
+: get-rc ( world -- )
+ handle>> dup hDC>> dup wglCreateContext dup win32-error=0/f
+ [ wglMakeCurrent win32-error=0/f ] keep >>hRC drop ;
-: get-rc ( hDC -- hRC )
- dup wglCreateContext dup win32-error=0/f
- [ wglMakeCurrent win32-error=0/f ] keep ;
+: set-pixel-format ( pixel-format hdc -- )
+ swap handle>> "PIXELFORMATDESCRIPTOR" <c-object> SetPixelFormat win32-error=0/f ;
-: setup-gl ( hwnd -- hDC hRC )
- get-dc dup windowed-pfd-dwFlags setup-pixel-format dup get-rc ;
+: setup-gl ( world -- )
+ [ get-dc ] keep
+ [ swap [ handle>> hDC>> set-pixel-format ] [ get-rc ] bi ]
+ with-world-pixel-format ;
M: windows-ui-backend (open-window) ( world -- )
- [ create-window [ setup-gl ] keep ] keep
- [ f <win> ] keep
- [ swap hWnd>> register-window ] 2keep
- dupd (>>handle)
- hWnd>> show-window ;
+ [ dup create-window [ f f ] dip f f <win> >>handle setup-gl ]
+ [ dup handle>> hWnd>> register-window ]
+ [ handle>> hWnd>> show-window ] tri ;
M: win-base select-gl-context ( handle -- )
[ hDC>> ] [ hRC>> ] bi wglMakeCurrent win32-error=0/f
M: win-base flush-gl-context ( handle -- )
hDC>> SwapBuffers win32-error=0/f ;
-: setup-offscreen-gl ( dim -- hDC hRC hBitmap bits )
- make-offscreen-dc-and-bitmap [
- [ dup offscreen-pfd-dwFlags setup-pixel-format ]
- [ get-rc ] bi
- ] 2dip ;
+: setup-offscreen-gl ( world -- )
+ dup [ handle>> ] [ dim>> ] bi make-offscreen-dc-and-bitmap
+ [ >>hDC ] [ >>hBitmap ] [ >>bits ] tri* drop [
+ swap [ handle>> hDC>> set-pixel-format ] [ get-rc ] bi
+ ] with-world-pixel-format ;
M: windows-ui-backend (open-offscreen-buffer) ( world -- )
- dup dim>> setup-offscreen-gl <win-offscreen>
- >>handle drop ;
+ win-offscreen new >>handle
+ setup-offscreen-gl ;
M: windows-ui-backend (close-offscreen-buffer) ( handle -- )
[ hDC>> DeleteDC drop ]
x11.glx x11.clipboard x11.constants x11.windows x11.io
io.encodings.string io.encodings.ascii io.encodings.utf8 combinators
command-line math.vectors classes.tuple opengl.gl threads
-math.rectangles environment ascii ;
+math.rectangles environment ascii literals
+ui.pixel-formats ui.pixel-formats.private ;
IN: ui.backend.x11
SINGLETON: x11-ui-backend
! In case dimensions didn't change
relayout-1 ;
+PIXEL-FORMAT-ATTRIBUTE-TABLE: glx-visual { $ GLX_USE_GL $ GLX_RGBA } H{
+ { double-buffered { $ GLX_DOUBLEBUFFER } }
+ { stereo { $ GLX_STEREO } }
+ { color-bits { $ GLX_BUFFER_SIZE } }
+ { red-bits { $ GLX_RED_SIZE } }
+ { green-bits { $ GLX_GREEN_SIZE } }
+ { blue-bits { $ GLX_BLUE_SIZE } }
+ { alpha-bits { $ GLX_ALPHA_SIZE } }
+ { accum-red-bits { $ GLX_ACCUM_RED_SIZE } }
+ { accum-green-bits { $ GLX_ACCUM_GREEN_SIZE } }
+ { accum-blue-bits { $ GLX_ACCUM_BLUE_SIZE } }
+ { accum-alpha-bits { $ GLX_ACCUM_ALPHA_SIZE } }
+ { depth-bits { $ GLX_DEPTH_SIZE } }
+ { stencil-bits { $ GLX_STENCIL_SIZE } }
+ { aux-buffers { $ GLX_AUX_BUFFERS } }
+ { sample-buffers { $ GLX_SAMPLE_BUFFERS } }
+ { samples { $ GLX_SAMPLES } }
+}
+
+M: x11-ui-backend (make-pixel-format)
+ [ drop dpy get scr get ] dip
+ >glx-visual-int-array glXChooseVisual ;
+
+M: x11-ui-backend (free-pixel-format)
+ handle>> XFree ;
+
+M: x11-ui-backend (pixel-format-attribute)
+ [ dpy get ] 2dip
+ [ handle>> ] [ >glx-visual ] bi*
+ [ 2drop f ] [
+ first
+ 0 <int> [ glXGetConfig drop ] keep *int
+ ] if-empty ;
+
CONSTANT: modifiers
{
{ S+ HEX: 1 }
: gadget-window ( world -- )
dup
- [ window-loc>> ] [ dim>> ] bi glx-window swap
+ [ [ [ window-loc>> ] [ dim>> ] bi ] dip handle>> glx-window ]
+ with-world-pixel-format swap
dup "Factor" create-xic
<x11-handle>
[ window>> register-window ] [ >>handle drop ] 2bi ;
drop ;
M: x11-ui-backend (open-offscreen-buffer) ( world -- )
- dup dim>> glx-pixmap <x11-pixmap-handle> >>handle drop ;
+ dup [ [ dim>> ] [ handle>> ] bi* glx-pixmap ]
+ with-world-pixel-format
+ <x11-pixmap-handle> >>handle drop ;
M: x11-ui-backend (close-offscreen-buffer) ( handle -- )
dpy get swap
[ glx-pixmap>> glXDestroyGLXPixmap ]
USING: accessors arrays hashtables kernel models math namespaces
make sequences quotations math.vectors combinators sorting
binary-search vectors dlists deques models threads
-concurrency.flags math.order math.rectangles fry locals ;
+concurrency.flags math.order math.rectangles fry locals
+prettyprint.backend prettyprint.custom ;
IN: ui.gadgets
! Values for orientation slot
boundary
model ;
+! Don't print gadgets with RECT: syntax
+M: gadget pprint* pprint-tuple ;
+
M: gadget equal? 2drop f ;
M: gadget hashcode* nip [ [ \ gadget counter ] unless* ] change-id id>> ;
{ $notes "If the " { $snippet "model" } " is " { $snippet "status" } ", this gadget will display mouse over help for " { $link "ui.gadgets.presentations" } "." } ;
HELP: open-status-window
-{ $values { "gadget" gadget } { "title" string } }
+{ $values { "gadget" gadget } { "title/attributes" { "a " { $link string } " or a " { $link world-attributes } " tuple" } } }
{ $description "Like " { $link open-window } ", with the additional feature that the new window iwll have a status bar displaying the value stored in the world's " { $slot "status" } " slot." }
{ $see-also show-status hide-status } ;
{ $subsection hide-status }
{ $link "ui.gadgets.presentations" } " use the status bar to display object summary." ;
-ABOUT: "ui.gadgets.status-bar"
\ No newline at end of file
+ABOUT: "ui.gadgets.status-bar"
! See http://factorcode.org/license.txt for BSD license.
USING: accessors models models.delay models.arrow
sequences ui.gadgets.labels ui.gadgets.tracks
-ui.gadgets.worlds ui.gadgets ui kernel calendar summary ;
+ui.gadgets.worlds ui.gadgets ui ui.private kernel calendar summary ;
IN: ui.gadgets.status-bar
: <status-bar> ( model -- gadget )
reverse-video-theme
t >>root? ;
-: open-status-window ( gadget title -- )
- f <model> [ <world> ] keep
- <status-bar> f track-add
+: open-status-window ( gadget title/attributes -- )
+ ?attributes f <model> >>status <world>
+ dup status>> <status-bar> f track-add
open-world-window ;
: show-summary ( object gadget -- )
USING: ui.gadgets ui.render ui.text ui.text.private
ui.gestures ui.backend help.markup help.syntax
-models opengl strings ;
+models opengl sequences strings ;
IN: ui.gadgets.worlds
HELP: user-input
} ;
HELP: <world>
-{ $values { "gadget" gadget } { "title" string } { "status" model } { "world" "a new " { $link world } } }
-{ $description "Creates a new " { $link world } " delegating to the given gadget." } ;
+{ $values { "world-attributes" world-attributes } { "world" "a new " { $link world } } }
+{ $description "Creates a new " { $link world } " or world subclass with the given attributes." } ;
HELP: find-world
{ $values { "gadget" gadget } { "world/f" { $maybe world } } }
{ $description "Makes the OpenGL context of the gadget's containing native window the current OpenGL context." }
{ $notes "This word should be called from " { $link graft* } " and " { $link ungraft* } " methods which need to allocate and deallocate OpenGL resources, such as textures, display lists, and so on." } ;
+HELP: begin-world
+{ $values { "world" world } }
+{ $description "Called immediately after " { $snippet "world" } "'s OpenGL context has been created. The world's OpenGL context is current when this method is called." } ;
+
+HELP: end-world
+{ $values { "world" world } }
+{ $description "Called immediately before " { $snippet "world" } "'s OpenGL context is destroyed. The world's OpenGL context is current when this method is called." } ;
+
+HELP: resize-world
+{ $values { "world" world } }
+{ $description "Called when the window containing " { $snippet "world" } " is resized. The " { $snippet "loc" } " and " { $snippet "dim" } " slots of " { $snippet "world" } " will be updated with the world's new position and size. The world's OpenGL context is current when this method is called." } ;
+
+HELP: draw-world*
+{ $values { "world" world } }
+{ $description "Called when " { $snippet "world" } " needs to be redrawn. The world's OpenGL context is current when this method is called." } ;
+
+ARTICLE: "ui.gadgets.worlds-subclassing" "Subclassing worlds"
+"The " { $link world } " gadget can be subclassed, giving Factor code full control of the window's OpenGL context. The following generic words can be overridden to replace standard UI behavior:"
+{ $subsection begin-world }
+{ $subsection end-world }
+{ $subsection resize-world }
+{ $subsection draw-world* }
+"See the " { $vocab-link "spheres" } " and " { $vocab-link "bunny" } " demos for examples." ;
+
ARTICLE: "ui-paint-custom" "Implementing custom drawing logic"
"The UI uses OpenGL to render gadgets. Custom rendering logic can be plugged in with the " { $link "ui-pen-protocol" } ", or by implementing a generic word:"
{ $subsection draw-gadget* }
$nl
"Gadgets which need to allocate and deallocate OpenGL resources such as textures, display lists, and so on, should perform the allocation in the " { $link graft* } " method, and the deallocation in the " { $link ungraft* } " method. Since those words are not necessarily called with the gadget's OpenGL context active, a utility word can be used to find and make the correct OpenGL context current:"
{ $subsection find-gl-context }
-"OpenGL state must not be altered as a result of drawing a gadget, so any flags which were enabled should be disabled, and vice versa."
+"OpenGL state must not be altered as a result of drawing a gadget, so any flags which were enabled should be disabled, and vice versa. To take full control of the OpenGL context, see " { $link "ui.gadgets.worlds-subclassing" } "."
{ $subsection "ui-paint-coord" }
+{ $subsection "ui.gadgets.worlds-subclassing" }
{ $subsection "gl-utilities" }
{ $subsection "text-rendering" } ;
namespaces opengl opengl.textures sequences io combinators
combinators.short-circuit fry math.vectors math.rectangles cache
ui.gadgets ui.gestures ui.render ui.backend ui.gadgets.tracks
-ui.commands ;
+ui.commands ui.pixel-formats destructors literals ;
IN: ui.gadgets.worlds
+CONSTANT: default-world-pixel-format-attributes
+ { windowed double-buffered T{ depth-bits { value 16 } } }
+
TUPLE: world < track
-active? focused?
-layers
-title status status-owner
-text-handle handle images
-window-loc ;
+ active? focused?
+ layers
+ title status status-owner
+ text-handle handle images
+ window-loc
+ pixel-format-attributes ;
+
+TUPLE: world-attributes
+ { world-class initial: world }
+ title
+ status
+ gadgets
+ { pixel-format-attributes initial: $ default-world-pixel-format-attributes } ;
+
+C: <world-attributes> world-attributes
: find-world ( gadget -- world/f ) [ world? ] find-parent ;
2dup eq?
[ 2drop ] [ dup focused?>> (request-focus) ] if ;
-: new-world ( gadget title status class -- world )
+: new-world ( class -- world )
vertical swap new-track
t >>root?
t >>active?
- { 0 0 } >>window-loc
- swap >>status
- swap >>title
- swap 1 track-add
+ { 0 0 } >>window-loc ;
+
+: apply-world-attributes ( world attributes -- world )
+ {
+ [ title>> >>title ]
+ [ status>> >>status ]
+ [ pixel-format-attributes>> >>pixel-format-attributes ]
+ [ gadgets>> [ 1 track-add ] each ]
+ } cleave ;
+
+: <world> ( world-attributes -- world )
+ [ world-class>> new-world ] keep apply-world-attributes
dup request-focus ;
-: <world> ( gadget title status -- world )
- world new-world ;
-
: as-big-as-possible ( world gadget -- )
dup [ { 0 0 } >>loc over dim>> >>dim ] when 2drop ; inline
flush-layout-cache-hook [ [ ] ] initialize
-: (draw-world) ( world -- )
- dup handle>> [
- check-extensions
- {
- [ init-gl ]
- [ draw-gadget ]
- [ text-handle>> [ purge-cache ] when* ]
- [ images>> [ purge-cache ] when* ]
- } cleave
- ] with-gl-context
- flush-layout-cache-hook get call( -- ) ;
+GENERIC: begin-world ( world -- )
+GENERIC: end-world ( world -- )
+
+GENERIC: resize-world ( world -- )
+
+M: world begin-world
+ drop ;
+M: world end-world
+ drop ;
+M: world resize-world
+ drop ;
+
+M: world (>>dim)
+ [ call-next-method ]
+ [
+ dup handle>>
+ [ select-gl-context resize-world ]
+ [ drop ] if*
+ ] bi ;
+
+GENERIC: draw-world* ( world -- )
+
+M: world draw-world*
+ check-extensions
+ {
+ [ init-gl ]
+ [ draw-gadget ]
+ [ text-handle>> [ purge-cache ] when* ]
+ [ images>> [ purge-cache ] when* ]
+ } cleave ;
: draw-world? ( world -- ? )
#! We don't draw deactivated worlds, or those with 0 size.
: draw-world ( world -- )
dup draw-world? [
dup world [
- [ (draw-world) ] [
+ [
+ dup handle>> [ draw-world* ] with-gl-context
+ flush-layout-cache-hook get call( -- )
+ ] [
over <world-error> ui-error
f >>active? drop
] recover
: close-global ( world global -- )
[ get-global find-world eq? ] keep '[ f _ set-global ] when ;
+
+M: world world-pixel-format-attributes
+ pixel-format-attributes>> ;
+
+M: world check-world-pixel-format
+ 2drop ;
+
+: with-world-pixel-format ( world quot -- )
+ [ dup dup world-pixel-format-attributes <pixel-format> ]
+ dip [ 2dup check-world-pixel-format ] prepose with-disposal ; inline
+
--- /dev/null
+USING: destructors help.markup help.syntax kernel math multiline sequences
+vocabs vocabs.parser words ;
+IN: ui.pixel-formats
+
+! break circular dependency
+<<
+ "ui.gadgets.worlds" create-vocab drop
+ "world" "ui.gadgets.worlds" create drop
+ "ui.gadgets.worlds" (use+)
+>>
+
+ARTICLE: "ui.pixel-formats-attributes" "Pixel format attributes"
+"The following pixel format attributes can be requested and queried of " { $link pixel-format } "s. Binary attributes are represented by the presence of a symbol in an attribute sequence:"
+{ $subsection double-buffered }
+{ $subsection stereo }
+{ $subsection offscreen }
+{ $subsection fullscreen }
+{ $subsection windowed }
+{ $subsection accelerated }
+{ $subsection software-rendered }
+{ $subsection backing-store }
+{ $subsection multisampled }
+{ $subsection supersampled }
+{ $subsection sample-alpha }
+{ $subsection color-float }
+"Integer attributes are represented by a " { $link tuple } " with a single " { $snippet "value" } "slot:"
+{ $subsection color-bits }
+{ $subsection red-bits }
+{ $subsection green-bits }
+{ $subsection blue-bits }
+{ $subsection alpha-bits }
+{ $subsection accum-bits }
+{ $subsection accum-red-bits }
+{ $subsection accum-green-bits }
+{ $subsection accum-blue-bits }
+{ $subsection accum-alpha-bits }
+{ $subsection depth-bits }
+{ $subsection stencil-bits }
+{ $subsection aux-buffers }
+{ $subsection sample-buffers }
+{ $subsection samples }
+{ $examples
+"The following " { $link world } " subclass will request a double-buffered window with minimum 24-bit color and depth buffers, and will throw an error if the requirements aren't met:"
+{ $code <"
+USING: kernel ui.worlds ui.pixel-formats ;
+IN: ui.pixel-formats.examples
+
+TUPLE: picky-depth-buffered-world < world ;
+
+M: picky-depth-buffered-world world-pixel-format-attributes
+ drop {
+ double-buffered
+ T{ color-bits { value 24 } }
+ T{ depth-bits { value 24 } }
+ } ;
+
+M: picky-depth-buffered-world check-world-pixel-format
+ nip
+ [ double-buffered pixel-format-attribute 0 = [ "Not double buffered!" throw ] when ]
+ [ color-bits pixel-format-attribute 24 < [ "Not enough color bits!" throw ] when ]
+ [ depth-bits pixel-format-attribute 24 < [ "Not enough depth bits!" throw ] when ]
+ tri ;
+"> } }
+;
+
+HELP: double-buffered
+{ $class-description "Requests a double-buffered pixel format." } ;
+HELP: stereo
+{ $class-description "Requests a stereoscopic pixel format." } ;
+
+HELP: offscreen
+{ $class-description "Requests a pixel format suitable for offscreen rendering." } ;
+HELP: fullscreen
+{ $class-description "Requests a pixel format suitable for fullscreen rendering." }
+{ $notes "On some window systems this is not distinct from " { $link windowed } "." } ;
+HELP: windowed
+{ $class-description "Requests a pixel format suitable for rendering to a window." } ;
+
+{ offscreen fullscreen windowed } related-words
+
+HELP: accelerated
+{ $class-description "Requests a pixel format supported by GPU hardware acceleration." } ;
+HELP: software-rendered
+{ $class-description "Requests a pixel format only supported by the window system's default software renderer." } ;
+
+{ accelerated software-rendered } related-words
+
+HELP: backing-store
+{ $class-description "Used with " { $link double-buffered } " to request a double-buffered pixel format where the back buffer contents are preserved and copied to the front when buffers are swapped." } ;
+
+{ double-buffered backing-store } related-words
+
+HELP: multisampled
+{ $class-description "Requests a pixel format with multisampled antialiasing enabled. The " { $link sample-buffers } " and " { $link samples } " attributes must also be provided to specify the level of multisampling." }
+{ $notes "On some window systems this is not distinct from " { $link supersampled } "." } ;
+
+HELP: supersampled
+{ $class-description "Requests a pixel format with supersampled antialiasing enabled. The " { $link sample-buffers } " and " { $link samples } " attributes must also be provided to specify the level of supersampling." }
+{ $notes "On some window systems this is not distinct from " { $link multisampled } "." } ;
+
+HELP: sample-alpha
+{ $class-description "Used with " { $link multisampled } " or " { $link supersampled } " to request more accurate multisampling of alpha values." } ;
+
+HELP: color-float
+{ $class-description "Requests a pixel format where the color buffer is stored in floating-point format." } ;
+
+HELP: color-bits
+{ $class-description "Requests a pixel format with a color buffer of at least " { $snippet "value" } " bits per pixel." } ;
+HELP: red-bits
+{ $class-description "Requests a pixel format with a color buffer with at least " { $snippet "value" } " red bits per pixel." } ;
+HELP: green-bits
+{ $class-description "Requests a pixel format with a color buffer with at least " { $snippet "value" } " green bits per pixel." } ;
+HELP: blue-bits
+{ $class-description "Requests a pixel format with a color buffer with at least " { $snippet "value" } " blue bits per pixel." } ;
+HELP: alpha-bits
+{ $class-description "Requests a pixel format with a color buffer with at least " { $snippet "value" } " alpha bits per pixel." } ;
+
+{ color-float color-bits red-bits green-bits blue-bits alpha-bits } related-words
+
+HELP: accum-bits
+{ $class-description "Requests a pixel format with an accumulation buffer of at least " { $snippet "value" } " bits per pixel." } ;
+HELP: accum-red-bits
+{ $class-description "Requests a pixel format with an accumulation buffer with at least " { $snippet "value" } " red bits per pixel." } ;
+HELP: accum-green-bits
+{ $class-description "Requests a pixel format with an accumulation buffer with at least " { $snippet "value" } " green bits per pixel." } ;
+HELP: accum-blue-bits
+{ $class-description "Requests a pixel format with an accumulation buffer with at least " { $snippet "value" } " blue bits per pixel." } ;
+HELP: accum-alpha-bits
+{ $class-description "Requests a pixel format with an accumulation buffer with at least " { $snippet "value" } " alpha bits per pixel." } ;
+
+{ accum-bits accum-red-bits accum-green-bits accum-blue-bits accum-alpha-bits } related-words
+
+HELP: depth-bits
+{ $class-description "Requests a pixel format with a depth buffer of at least " { $snippet "value" } " bits per pixel." } ;
+
+HELP: stencil-bits
+{ $class-description "Requests a pixel format with a stencil buffer of at least " { $snippet "value" } " bits per pixel." } ;
+
+HELP: aux-buffers
+{ $class-description "Requests a pixel format with at least " { $snippet "value" } " auxiliary buffers." } ;
+
+HELP: sample-buffers
+{ $class-description "Used with " { $link multisampled } " or " { $link supersampled } " to request a pixel format with at least " { $snippet "value" } " sampling buffers." } ;
+
+HELP: samples
+{ $class-description "Used with " { $link multisampled } " or " { $link supersampled } " to request at least " { $snippet "value" } " samples per pixel." } ;
+
+{ multisampled supersampled sample-alpha sample-buffers samples } related-words
+
+HELP: world-pixel-format-attributes
+{ $values { "world" world } { "attributes" sequence } }
+{ $description "Returns the set of " { $link "ui.pixel-formats-attributes" } " that " { $snippet "world" } " requests when grafted. This generic can be overridden by subclasses of " { $snippet "world" } "." }
+{ $notes "The pixel format provided by the window system will not necessarily exactly match the requested attributes. To verify required pixel format attributes, override " { $link check-world-pixel-format } "." } ;
+
+HELP: check-world-pixel-format
+{ $values { "world" world } { "pixel-format" pixel-format } }
+{ $description "Verifies that " { $snippet "pixel-format" } " fulfills the requirements of " { $snippet "world" } ". The default method does nothing. Subclasses can override this generic to perform their own checks on the pixel format." } ;
+
+HELP: pixel-format
+{ $class-description "The type of pixel format objects. The tuple slot contents should be considered opaque by user code. To check the value of a pixel format's attributes, use the " { $link pixel-format-attribute } " word. Pixel format objects must be freed using the " { $link dispose } " word when they are no longer needed." } ;
+
+HELP: <pixel-format>
+{ $values { "world" world } { "attributes" sequence } { "pixel-format" pixel-format } }
+{ $description "Requests a pixel format suitable for " { $snippet "world" } " with a set of " { $link "ui.pixel-formats-attributes" } ". If no pixel format can be found that satisfies the given attributes, an " { $link invalid-pixel-format-attributes } " error is thrown. Pixel format attributes not supported by the window system are ignored. The returned " { $snippet "pixel-format" } " must be released using the " { $link dispose } " word when it is no longer needed." }
+{ $notes "Pixel formats don't normally need to be directly allocated by user code. If you need to control the pixel format requested by a window, subclass " { $snippet "world" } " and override the " { $link world-pixel-format-attributes } " and " { $link check-world-pixel-format } " words."
+$nl
+"The returned pixel format does not necessarily exactly match the requested attributes; the window system will try to find the format that best matches the given attributes. Use " { $link pixel-format-attribute } " to check the actual values of the attributes on the returned pixel format." }
+;
+
+HELP: pixel-format-attribute
+{ $values { "pixel-format" pixel-format } { "attribute-name" "one of the " { $link "ui.pixel-formats-attributes" } } { "value" object } }
+{ $description "Returns the value of the requested " { $snippet "attribute-name" } " in " { $snippet "pixel-format" } ". If " { "attribute-name" } " is unsupported by the window system, " { $link f } " is returned." } ;
+
+HELP: invalid-pixel-format-attributes
+{ $values { "world" world } { "attributes" sequence } }
+{ $class-description "Thrown by " { $link <pixel-format> } " when the window system is unable to find a pixel format for " { $snippet "world" } " that satisfies the requested " { $snippet "attributes" } "." } ;
+
+{ world-pixel-format-attributes check-world-pixel-format pixel-format <pixel-format> pixel-format-attribute }
+related-words
+
+ARTICLE: "ui.pixel-formats" "Pixel formats"
+"The UI allows you to control the window system's OpenGL interface with a cross-platform set of pixel format specifiers:"
+{ $subsection "ui.pixel-formats-attributes" }
+
+"Pixel formats can be requested using these attributes:"
+{ $subsection pixel-format }
+{ $subsection <pixel-format> }
+{ $subsection pixel-format-attribute }
+
+"If a request for a set of pixel format attributes cannot be satisfied, an error is thrown:"
+{ $subsection invalid-pixel-format-attributes }
+
+"Pixel formats are requested as part of opening a window for a " { $link world } ". These generics can be overridden on " { $snippet "world" } " subclasses to control pixel format selection:"
+{ $subsection world-pixel-format-attributes }
+{ $subsection check-world-pixel-format }
+;
+
+ABOUT: "ui.pixel-formats"
--- /dev/null
+USING: accessors assocs classes destructors functors kernel
+lexer math parser sequences specialized-arrays.int ui.backend
+words.symbol ;
+IN: ui.pixel-formats
+
+SYMBOLS:
+ double-buffered
+ stereo
+ offscreen
+ fullscreen
+ windowed
+ accelerated
+ software-rendered
+ backing-store
+ multisampled
+ supersampled
+ sample-alpha
+ color-float ;
+
+TUPLE: pixel-format-attribute { value integer } ;
+
+TUPLE: color-bits < pixel-format-attribute ;
+TUPLE: red-bits < pixel-format-attribute ;
+TUPLE: green-bits < pixel-format-attribute ;
+TUPLE: blue-bits < pixel-format-attribute ;
+TUPLE: alpha-bits < pixel-format-attribute ;
+
+TUPLE: accum-bits < pixel-format-attribute ;
+TUPLE: accum-red-bits < pixel-format-attribute ;
+TUPLE: accum-green-bits < pixel-format-attribute ;
+TUPLE: accum-blue-bits < pixel-format-attribute ;
+TUPLE: accum-alpha-bits < pixel-format-attribute ;
+
+TUPLE: depth-bits < pixel-format-attribute ;
+
+TUPLE: stencil-bits < pixel-format-attribute ;
+
+TUPLE: aux-buffers < pixel-format-attribute ;
+
+TUPLE: sample-buffers < pixel-format-attribute ;
+TUPLE: samples < pixel-format-attribute ;
+
+HOOK: (make-pixel-format) ui-backend ( world attributes -- pixel-format-handle )
+HOOK: (free-pixel-format) ui-backend ( pixel-format -- )
+HOOK: (pixel-format-attribute) ui-backend ( pixel-format attribute-name -- value )
+
+ERROR: invalid-pixel-format-attributes world attributes ;
+
+TUPLE: pixel-format world handle ;
+
+: <pixel-format> ( world attributes -- pixel-format )
+ 2dup (make-pixel-format)
+ [ nip pixel-format boa ] [ invalid-pixel-format-attributes ] if* ;
+
+M: pixel-format dispose
+ [ (free-pixel-format) ] [ f >>handle drop ] bi ;
+
+: pixel-format-attribute ( pixel-format attribute-name -- value )
+ (pixel-format-attribute) ;
+
+<PRIVATE
+
+FUNCTOR: define-pixel-format-attribute-table ( NAME PERM TABLE -- )
+
+>PFA DEFINES >${NAME}
+>PFA-int-array DEFINES >${NAME}-int-array
+
+WHERE
+
+GENERIC: >PFA ( attribute -- pfas )
+
+M: object >PFA
+ drop { } ;
+M: symbol >PFA
+ TABLE at [ { } ] unless* ;
+M: pixel-format-attribute >PFA
+ dup class TABLE at
+ [ swap value>> suffix ]
+ [ drop { } ] if* ;
+
+: >PFA-int-array ( attribute -- int-array )
+ [ >PFA ] map concat PERM prepend 0 suffix >int-array ;
+
+;FUNCTOR
+
+SYNTAX: PIXEL-FORMAT-ATTRIBUTE-TABLE:
+ scan scan-object scan-object define-pixel-format-attribute-table ;
+
+PRIVATE>
+
+GENERIC: world-pixel-format-attributes ( world -- attributes )
+
+GENERIC# check-world-pixel-format 1 ( world pixel-format -- )
+
--- /dev/null
+Cross-platform OpenGL context pixel format specifiers
USING: vocabs.loader namespaces system combinators ;
-"ui-backend" get [
- {
- { [ os macosx? ] [ "core-text" ] }
- { [ os windows? ] [ "uniscribe" ] }
- { [ os unix? ] [ "pango" ] }
- } cond
-] unless* "ui.text." prepend require
\ No newline at end of file
+{
+ { [ os macosx? ] [ "core-text" ] }
+ { [ os windows? ] [ "uniscribe" ] }
+ { [ os unix? ] [ "pango" ] }
+} cond "ui.text." prepend require
[ ] [
[
"interactor" get register-self
- "interactor" get contents "promise" get fulfill
+ "interactor" get stream-contents "promise" get fulfill
] in-thread
] unit-test
[ ] [ <listener-gadget> "l" set ] unit-test
[ ] [ "l" get com-scroll-up ] unit-test
-[ ] [ "l" get com-scroll-down ] unit-test
\ No newline at end of file
+[ ] [ "l" get com-scroll-down ] unit-test
namespaces ui.backend ui.gadgets ui.gadgets.worlds
ui.gadgets.tracks ui.gadgets.packs ui.gadgets.grids
ui.gadgets.private math.rectangles colors ui.text fonts
-kernel ui.private ;
+kernel ui.private classes sequences ;
IN: ui
HELP: windows
{ $var-description "Global variable holding an association list mapping native window handles to " { $link world } " instances." } ;
-{ windows open-window find-window } related-words
+{ windows open-window find-window world-attributes } related-words
HELP: open-window
-{ $values { "gadget" gadget } { "title" string } }
-{ $description "Opens a native window with the specified title." } ;
+{ $values { "gadget" gadget } { "title/attributes" { "a " { $link string } " or a " { $link world-attributes } " tuple" } } }
+{ $description "Opens a native window containing " { $snippet "gadget" } " with the specified attributes. If a string is provided, it is used as the window title; otherwise, the window attributes are specified in a " { $link world-attributes } " tuple." } ;
+
+HELP: world-attributes
+{ $values { "world-class" class } { "title" string } { "status" gadget } { "gadgets" sequence } { "pixel-format-attributes" sequence } }
+{ $class-description "Tuples of this class can be passed to " { $link open-window } " to control attributes of the window opened. The following attributes can be set:" }
+{ $list
+ { { $snippet "world-class" } " specifies the class of world to construct. " { $link world } " is the default." }
+ { { $snippet "title" } " is the window title." }
+ { { $snippet "status" } ", if specified, is a gadget that will be used as the window's status bar." }
+ { { $snippet "gadgets" } " is a sequence of gadgets that will be placed inside the window." }
+ { { $snippet "pixel-format-attributes" } " is a sequence of " { $link "ui.pixel-formats-attributes" } " that the window will request for its OpenGL pixel format." }
+} ;
HELP: set-fullscreen?
{ $values { "?" "a boolean" } { "gadget" gadget } }
deques sequences threads sequences words continuations init
combinators combinators.short-circuit hashtables concurrency.flags
sets accessors calendar fry destructors ui.gadgets ui.gadgets.private
-ui.gadgets.worlds ui.gadgets.tracks ui.gestures ui.backend ui.render ;
+ui.gadgets.worlds ui.gadgets.tracks ui.gestures ui.backend ui.render
+strings ;
IN: ui
<PRIVATE
f >>focused?
focus-path f swap focus-gestures ;
+: try-to-open-window ( world -- )
+ {
+ [ (open-window) ]
+ [ handle>> select-gl-context ]
+ [
+ [ begin-world ]
+ [ [ handle>> (close-window) ] [ ui-error ] bi* ]
+ recover
+ ]
+ [ resize-world ]
+ } cleave ;
+
M: world graft*
- [ (open-window) ]
+ [ try-to-open-window ]
[ [ title>> ] keep set-title ]
[ request-focus ] tri ;
[ images>> [ dispose ] when* ]
[ hand-clicked close-global ]
[ hand-gadget close-global ]
+ [ end-world ]
} cleave ;
M: world ungraft*
: restore-windows? ( -- ? )
windows get empty? not ;
+: ?attributes ( gadget title/attributes -- attributes )
+ dup string? [ world-attributes new swap >>title ] when
+ swap [ [ [ 1array ] [ f ] if* ] curry unless* ] curry change-gadgets ;
+
PRIVATE>
: open-world-window ( world -- )
dup pref-dim >>dim dup relayout graft ;
-: open-window ( gadget title -- )
- f <world> open-world-window ;
+: open-window ( gadget title/attributes -- )
+ ?attributes <world> open-world-window ;
: set-fullscreen? ( ? gadget -- )
find-world set-fullscreen* ;
USING: alien.c-types kernel locals math math.bitwise
windows.kernel32 sequences byte-arrays unicode.categories
io.encodings.string io.encodings.utf16n alien.strings
-arrays ;
+arrays literals ;
IN: windows.errors
CONSTANT: ERROR_SUCCESS 0
win32-error-string throw
] when ;
-: expected-io-errors ( -- seq )
- ERROR_SUCCESS
- ERROR_IO_INCOMPLETE
- ERROR_IO_PENDING
- WAIT_TIMEOUT 4array ; foldable
+CONSTANT: expected-io-errors
+ ${
+ ERROR_SUCCESS
+ ERROR_IO_INCOMPLETE
+ ERROR_IO_PENDING
+ WAIT_TIMEOUT
+ }
: expected-io-error? ( error-code -- ? )
expected-io-errors member? ;
! FUNCTION: DeleteMetaFile
FUNCTION: BOOL DeleteObject ( HGDIOBJ hObject ) ;
DESTRUCTOR: DeleteObject
-! FUNCTION: DescribePixelFormat
+FUNCTION: int DescribePixelFormat ( HDC hdc, int iPixelFormat, UINT nBytes, PIXELFORMATDESCRIPTOR* ppfd ) ;
! FUNCTION: DeviceCapabilitiesExA
! FUNCTION: DeviceCapabilitiesExW
! FUNCTION: DPtoLP
! 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.bitwise windows.types windows.types init assocs
-sequences libc ;
+math math.bitwise windows.types init assocs splitting
+sequences libc opengl.gl opengl.gl.extensions opengl.gl.windows ;
IN: windows.opengl32
! PIXELFORMATDESCRIPTOR flags
CONSTANT: WGL_SWAP_UNDERLAY14 HEX: 20000000
CONSTANT: WGL_SWAP_UNDERLAY15 HEX: 40000000
-: windowed-pfd-dwFlags ( -- n )
- { PFD_DRAW_TO_WINDOW PFD_SUPPORT_OPENGL PFD_DOUBLEBUFFER } flags ;
-: offscreen-pfd-dwFlags ( -- n )
- { PFD_DRAW_TO_BITMAP PFD_SUPPORT_OPENGL } flags ;
-
-! TODO: compare to http://www.nullterminator.net/opengl32.html
-: make-pfd ( flags bits -- pfd )
- "PIXELFORMATDESCRIPTOR" <c-object>
- "PIXELFORMATDESCRIPTOR" heap-size over set-PIXELFORMATDESCRIPTOR-nSize
- 1 over set-PIXELFORMATDESCRIPTOR-nVersion
- rot over set-PIXELFORMATDESCRIPTOR-dwFlags
- PFD_TYPE_RGBA over set-PIXELFORMATDESCRIPTOR-iPixelType
- [ set-PIXELFORMATDESCRIPTOR-cColorBits ] keep
- 16 over set-PIXELFORMATDESCRIPTOR-cDepthBits
- PFD_MAIN_PLANE over set-PIXELFORMATDESCRIPTOR-dwLayerMask ;
-
LIBRARY: gl
FUNCTION: HGLRC wglCreateContext ( HDC hDC ) ;
FUNCTION: BOOL wglDeleteContext ( HGLRC hRC ) ;
FUNCTION: BOOL wglMakeCurrent ( HDC hDC, HGLRC hglrc ) ;
-FUNCTION: HGLRC wglGetCurrentContext ( ) ;
-FUNCTION: void* wglGetProcAddress ( char* name ) ;
+
+! WGL_ARB_extensions_string extension
+
+GL-FUNCTION: char* wglGetExtensionsStringARB { } ( HDC hDC ) ;
+
+! WGL_ARB_pixel_format extension
+
+CONSTANT: WGL_NUMBER_PIXEL_FORMATS_ARB HEX: 2000
+CONSTANT: WGL_DRAW_TO_WINDOW_ARB HEX: 2001
+CONSTANT: WGL_DRAW_TO_BITMAP_ARB HEX: 2002
+CONSTANT: WGL_ACCELERATION_ARB HEX: 2003
+CONSTANT: WGL_NEED_PALETTE_ARB HEX: 2004
+CONSTANT: WGL_NEED_SYSTEM_PALETTE_ARB HEX: 2005
+CONSTANT: WGL_SWAP_LAYER_BUFFERS_ARB HEX: 2006
+CONSTANT: WGL_SWAP_METHOD_ARB HEX: 2007
+CONSTANT: WGL_NUMBER_OVERLAYS_ARB HEX: 2008
+CONSTANT: WGL_NUMBER_UNDERLAYS_ARB HEX: 2009
+CONSTANT: WGL_TRANSPARENT_ARB HEX: 200A
+CONSTANT: WGL_TRANSPARENT_RED_VALUE_ARB HEX: 2037
+CONSTANT: WGL_TRANSPARENT_GREEN_VALUE_ARB HEX: 2038
+CONSTANT: WGL_TRANSPARENT_BLUE_VALUE_ARB HEX: 2039
+CONSTANT: WGL_TRANSPARENT_ALPHA_VALUE_ARB HEX: 203A
+CONSTANT: WGL_TRANSPARENT_INDEX_VALUE_ARB HEX: 203B
+CONSTANT: WGL_SHARE_DEPTH_ARB HEX: 200C
+CONSTANT: WGL_SHARE_STENCIL_ARB HEX: 200D
+CONSTANT: WGL_SHARE_ACCUM_ARB HEX: 200E
+CONSTANT: WGL_SUPPORT_GDI_ARB HEX: 200F
+CONSTANT: WGL_SUPPORT_OPENGL_ARB HEX: 2010
+CONSTANT: WGL_DOUBLE_BUFFER_ARB HEX: 2011
+CONSTANT: WGL_STEREO_ARB HEX: 2012
+CONSTANT: WGL_PIXEL_TYPE_ARB HEX: 2013
+CONSTANT: WGL_COLOR_BITS_ARB HEX: 2014
+CONSTANT: WGL_RED_BITS_ARB HEX: 2015
+CONSTANT: WGL_RED_SHIFT_ARB HEX: 2016
+CONSTANT: WGL_GREEN_BITS_ARB HEX: 2017
+CONSTANT: WGL_GREEN_SHIFT_ARB HEX: 2018
+CONSTANT: WGL_BLUE_BITS_ARB HEX: 2019
+CONSTANT: WGL_BLUE_SHIFT_ARB HEX: 201A
+CONSTANT: WGL_ALPHA_BITS_ARB HEX: 201B
+CONSTANT: WGL_ALPHA_SHIFT_ARB HEX: 201C
+CONSTANT: WGL_ACCUM_BITS_ARB HEX: 201D
+CONSTANT: WGL_ACCUM_RED_BITS_ARB HEX: 201E
+CONSTANT: WGL_ACCUM_GREEN_BITS_ARB HEX: 201F
+CONSTANT: WGL_ACCUM_BLUE_BITS_ARB HEX: 2020
+CONSTANT: WGL_ACCUM_ALPHA_BITS_ARB HEX: 2021
+CONSTANT: WGL_DEPTH_BITS_ARB HEX: 2022
+CONSTANT: WGL_STENCIL_BITS_ARB HEX: 2023
+CONSTANT: WGL_AUX_BUFFERS_ARB HEX: 2024
+
+CONSTANT: WGL_NO_ACCELERATION_ARB HEX: 2025
+CONSTANT: WGL_GENERIC_ACCELERATION_ARB HEX: 2026
+CONSTANT: WGL_FULL_ACCELERATION_ARB HEX: 2027
+
+CONSTANT: WGL_SWAP_EXCHANGE_ARB HEX: 2028
+CONSTANT: WGL_SWAP_COPY_ARB HEX: 2029
+CONSTANT: WGL_SWAP_UNDEFINED_ARB HEX: 202A
+
+CONSTANT: WGL_TYPE_RGBA_ARB HEX: 202B
+CONSTANT: WGL_TYPE_COLORINDEX_ARB HEX: 202C
+
+GL-FUNCTION: BOOL wglGetPixelFormatAttribivARB { } (
+ HDC hdc,
+ int iPixelFormat,
+ int iLayerPlane,
+ UINT nAttributes,
+ int* piAttributes,
+ int* piValues
+ ) ;
+
+GL-FUNCTION: BOOL wglGetPixelFormatAttribfvARB { } (
+ HDC hdc,
+ int iPixelFormat,
+ int iLayerPlane,
+ UINT nAttributes,
+ int* piAttributes,
+ FLOAT* pfValues
+ ) ;
+
+GL-FUNCTION: BOOL wglChoosePixelFormatARB { } (
+ HDC hdc,
+ int* piAttribIList,
+ FLOAT* pfAttribFList,
+ UINT nMaxFormats,
+ int* piFormats,
+ UINT* nNumFormats
+ ) ;
+
+! WGL_ARB_multisample extension
+
+CONSTANT: WGL_SAMPLE_BUFFERS_ARB HEX: 2041
+CONSTANT: WGL_SAMPLES_ARB HEX: 2042
+
+! WGL_ARB_pixel_format_float extension
+
+CONSTANT: WGL_TYPE_RGBA_FLOAT_ARB HEX: 21A0
+
+! wgl extensions querying
+
+: has-wglGetExtensionsStringARB? ( -- ? )
+ "wglGetExtensionsStringARB" wglGetProcAddress >boolean ;
+
+: wgl-extensions ( hdc -- extensions )
+ has-wglGetExtensionsStringARB? [ wglGetExtensionsStringARB " " split ] [ drop { } ] if ;
+
+: has-wgl-extensions? ( hdc extensions -- ? )
+ swap wgl-extensions [ member? ] curry all? ;
+
+: has-wgl-pixel-format-extension? ( hdc -- ? )
+ { "WGL_ARB_pixel_format" } has-wgl-extensions? ;
! GLX_ARB_get_proc_address extension
X-FUNCTION: void* glXGetProcAddressARB ( char* procname ) ;
+! GLX_ARB_multisample
+CONSTANT: GLX_SAMPLE_BUFFERS 100000
+CONSTANT: GLX_SAMPLES 100001
+
+! GLX_ARB_fbconfig_float
+CONSTANT: GLX_RGBA_FLOAT_TYPE HEX: 20B9
+CONSTANT: GLX_RGBA_FLOAT_BIT HEX: 0004
+
! GLX Events
! (also skipped for now. only has GLXPbufferClobberEvent, the rest is handled by xlib methinks)
-: choose-visual ( flags -- XVisualInfo* )
- [ dpy get scr get ] dip
- [
- %
- GLX_RGBA ,
- GLX_DEPTH_SIZE , 16 ,
- 0 ,
- ] int-array{ } make
- glXChooseVisual
- [ "Could not get a double-buffered GLX RGBA visual" throw ] unless* ;
-
: create-glx ( XVisualInfo* -- GLXContext )
[ dpy get ] dip f 1 glXCreateContext
[ "Failed to create GLX context" throw ] unless* ;
dup
] dip auto-position ;
-: glx-window ( loc dim -- window glx )
- GLX_DOUBLEBUFFER 1array choose-visual
- [ create-window ] keep
- [ create-glx ] keep
- XFree ;
+: glx-window ( loc dim visual -- window glx )
+ [ create-window ] [ create-glx ] bi ;
: create-pixmap ( dim visual -- pixmap )
[ [ { 0 0 } swap ] dip create-window ] [
: create-glx-pixmap ( dim visual -- pixmap glx-pixmap )
[ create-pixmap ] [ (create-glx-pixmap) ] bi ;
-: glx-pixmap ( dim -- glx pixmap glx-pixmap )
- { } choose-visual
- [ nip create-glx ] [ create-glx-pixmap ] [ nip XFree ] 2tri ;
+: glx-pixmap ( dim visual -- glx pixmap glx-pixmap )
+ [ nip create-glx ] [ create-glx-pixmap ] 2bi ;
: destroy-window ( win -- )
dpy get swap XDestroyWindow drop ;
[XML <style><-></style> XML] ;
:: htmlize-stream ( path stream -- xml )
- stream lines
+ stream stream-lines
[ "" ] [ path over first find-mode htmlize-lines ]
if-empty :> input
default-stylesheet :> stylesheet
3drop f
] [
3dup nth-unsafe at*
- [ [ 3drop ] dip ] [ drop [ 1- ] dip (assoc-stack) ] if
+ [ [ 3drop ] dip ] [ drop [ 1 - ] dip (assoc-stack) ] if
] if ; inline recursive
: search-alist ( key alist -- pair/f i/f )
assoc-size 0 = ;
: assoc-stack ( key seq -- value )
- [ length 1- ] keep (assoc-stack) ; flushable
+ [ length 1 - ] keep (assoc-stack) ; flushable
: assoc-subset? ( assoc1 assoc2 -- ? )
[ at* [ = ] [ 2drop f ] if ] with-assoc assoc-all? ;
} [ [ first3 ] dip swap make-primitive ] each-index
! Bump build number
-"build" "kernel" create build 1+ [ ] curry (( -- n )) define-declared
+"build" "kernel" create build 1 + [ ] curry (( -- n )) define-declared
GENERIC: checksum-lines ( lines checksum -- value )
M: checksum checksum-stream
- [ contents ] dip checksum-bytes ;
+ [ stream-contents ] dip checksum-bytes ;
M: checksum checksum-lines
[ B{ CHAR: \n } join ] dip checksum-bytes ;
CONSTANT: crc32-table V{ }
-256 [
+256 iota [
8 [
[ 2/ ] [ even? ] bi [ crc32-polynomial bitxor ] unless
] times >bignum
" } ;"
""
": next-position ( role -- newrole )"
- " positions [ index 1+ ] keep nth ;"
+ " positions [ index 1 + ] keep nth ;"
""
": promote ( employee -- employee )"
" [ 1.2 * ] change-salary"
{
[ , ]
[ [ superclass class-size ] [ "slots" word-prop length ] bi + , ]
- [ superclasses length 1- , ]
+ [ superclasses length 1 - , ]
[ superclasses [ [ , ] [ hashcode , ] bi ] each ]
} cleave
] { } make ;
M: tuple tuple-hashcode
[
- [ class hashcode ] [ tuple-size ] [ ] tri
+ [ class hashcode ] [ tuple-size iota ] [ ] tri
[ rot ] dip [
swapd array-nth hashcode* sequence-hashcode-step
] 2curry each
[ [ [ literalize ] dip ] assoc-map linear-case-quot ] with map ;
: hash-dispatch-quot ( table -- quot )
- [ length 1- [ fixnum-bitand ] curry ] keep
+ [ length 1 - [ fixnum-bitand ] curry ] keep
[ dispatch ] curry append ;
: hash-case-quot ( default assoc -- quot )
! recursive-hashcode
: recursive-hashcode ( n obj quot -- code )
- pick 0 <= [ 3drop 0 ] [ [ 1- ] 2dip call ] if ; inline
+ pick 0 <= [ 3drop 0 ] [ [ 1 - ] 2dip call ] if ; inline
! These go here, not in sequences and hashtables, since those
! two cannot depend on us
IN: continuations.tests
: (callcc1-test) ( n obj -- n' obj )
- [ 1- dup ] dip ?push
+ [ 1 - dup ] dip ?push
over 0 = [ "test-cc" get continue-with ] when
(callcc1-test) ;
M: tuple-dispatch-engine compile-engine
tuple assumed [
echelons>> compile-engines
- dup keys supremum 1+ f <array>
+ dup keys supremum 1
+ f <array>
[ <enum> swap update ] keep
] with-variable ;
[ mega-cache-quot define ]
[ define-inline-cache-quot ]
2tri
- ] with-combination ;
\ No newline at end of file
+ ] with-combination ;
{ 0 [ [ dup ] ] }
{ 1 [ [ over ] ] }
{ 2 [ [ pick ] ] }
- [ 1- (picker) [ dip swap ] curry ]
+ [ 1 - (picker) [ dip swap ] curry ]
} case ;
M: standard-combination picker
] if
(>>length) ;
-: new-size ( old -- new ) 1+ 3 * ; inline
+: new-size ( old -- new ) 1 + 3 * ; inline
: ensure ( n seq -- n seq )
growable-check
[ no-key ] [ 2dup hash@ (key@) ] if ; inline
: <hash-array> ( n -- array )
- 1+ next-power-of-2 4 * ((empty)) <array> ; inline
+ 1
+ next-power-of-2 4 * ((empty)) <array> ; inline
: init-hash ( hash -- )
0 >>count 0 >>deleted drop ; inline
1 fixnum+fast set-slot ; inline
: hash-count+ ( hash -- )
- [ 1+ ] change-count drop ; inline
+ [ 1 + ] change-count drop ; inline
: hash-deleted+ ( hash -- )
- [ 1+ ] change-deleted drop ; inline
+ [ 1 + ] change-deleted drop ; inline
: (rehash) ( hash alist -- )
swap [ swapd set-at ] curry assoc-each ; inline
[ deleted>> 10 fixnum*fast ] [ count>> ] bi fixnum> ; inline
: grow-hash ( hash -- )
- [ [ >alist ] [ assoc-size 1+ ] bi ] keep
+ [ [ >alist ] [ assoc-size 1 + ] bi ] keep
[ reset-hash ] keep
swap (rehash) ;
PRIVATE>
M: hashtable >alist
- [ array>> [ length 2/ ] keep ] [ assoc-size <vector> ] bi [
+ [ array>> [ length 2/ iota ] keep ] [ assoc-size <vector> ] bi [
[
[
[ 1 fixnum-shift-fast ] dip
swap normalize-path (file-appender) swap <encoder> ;
: file-lines ( path encoding -- seq )
- <file-reader> lines ;
+ <file-reader> stream-lines ;
: with-file-reader ( path encoding quot -- )
[ <file-reader> ] dip with-input-stream ; inline
: file-contents ( path encoding -- seq )
- <file-reader> contents ;
+ <file-reader> stream-contents ;
: with-file-writer ( path encoding quot -- )
[ <file-writer> ] dip with-output-stream ; inline
{ $description "Outputs a space character (" { $snippet "\" \"" } ") to " { $link output-stream } "." }
$io-error ;
-HELP: lines
+HELP: stream-lines
{ $values { "stream" "an input stream" } { "seq" "a sequence of strings" } }
{ $description "Reads lines of text until the stream is exhausted, collecting them in a sequence of strings." } ;
+HELP: lines
+{ $values { "seq" "a sequence of strings" } }
+{ $description "Reads lines of text until from the " { $link input-stream } " until it is exhausted, collecting them in a sequence of strings." } ;
+
HELP: each-line
{ $values { "quot" { $quotation "( str -- )" } } }
{ $description "Calls the quotation with successive lines of text, until the current " { $link input-stream } " is exhausted." } ;
{ $values { "quot" { $quotation "( block -- )" } } }
{ $description "Calls the quotation with successive blocks of data, until the current " { $link input-stream } " is exhausted." } ;
-HELP: contents
+HELP: stream-contents
{ $values { "stream" "an input stream" } { "seq" "a string, byte array or " { $link f } } }
-{ $description "Reads the entire contents of a stream. If the stream is empty, outputs" { $link f } "." }
+{ $description "Reads the entire contents of a stream. If the stream is empty, outputs " { $link f } "." }
+$io-error ;
+
+HELP: contents
+{ $values { "seq" "a string, byte array or " { $link f } } }
+{ $description "Reads the entire contents of a the stream stored in " { $link input-stream } ". If the stream is empty, outputs " { $link f } "." }
$io-error ;
ARTICLE: "stream-protocol" "Stream protocol"
"First, a simple composition of " { $link stream-write } " and " { $link stream-nl } ":"
{ $subsection stream-print }
"Processing lines one by one:"
+{ $subsection stream-lines }
{ $subsection lines }
{ $subsection each-line }
"Processing blocks of data:"
+{ $subsection stream-contents }
{ $subsection contents }
{ $subsection each-block }
"Copying the contents of one stream to another:"
: bl ( -- ) " " write ;
-: lines ( stream -- seq )
+: stream-lines ( stream -- seq )
[ [ readln dup ] [ ] produce nip ] with-input-stream ;
+: lines ( -- seq )
+ input-stream get stream-lines ;
+
<PRIVATE
: each-morsel ( handler: ( data -- ) reader: ( -- data ) -- )
: each-line ( quot -- )
[ readln ] each-morsel ; inline
-: contents ( stream -- seq )
+: stream-contents ( stream -- seq )
[
[ 65536 read-partial dup ] [ ] produce nip concat f like
] with-input-stream ;
+: contents ( -- seq )
+ input-stream get stream-contents ;
+
: each-block ( quot: ( block -- ) -- )
[ 8192 read-partial ] each-morsel ; inline
[ path-separator? ] trim-head ;
: last-path-separator ( path -- n ? )
- [ length 1- ] keep [ path-separator? ] find-last-from ;
+ [ length 1 - ] keep [ path-separator? ] find-last-from ;
HOOK: root-directory? io-backend ( path -- ? )
dup root-directory? [
trim-tail-separators
dup last-path-separator [
- 1+ cut
+ 1 + cut
] [
drop "." swap
] if
: file-name ( path -- string )
dup root-directory? [
trim-tail-separators
- dup last-path-separator [ 1+ tail ] [
+ dup last-path-separator [ 1 + tail ] [
drop special-path? [ file-name ] when
] if
] unless ;
[ B{ BIN: 11110101 BIN: 10111111 BIN: 10000000 BIN: 10111111 BIN: 11101111 BIN: 10000000 BIN: 10111111 BIN: 11011111 BIN: 10000000 CHAR: x } ]
[ { BIN: 101111111000000111111 BIN: 1111000000111111 BIN: 11111000000 CHAR: x } >string utf8 [ write ] with-byte-writer ] unit-test
-[ { BIN: 101111111000000111111 } t ] [ { BIN: 11110101 BIN: 10111111 BIN: 10000000 BIN: 10111111 } utf8 <byte-reader> contents dup >array swap string? ] unit-test
+[ { BIN: 101111111000000111111 } t ] [ { BIN: 11110101 BIN: 10111111 BIN: 10000000 BIN: 10111111 } utf8 <byte-reader> stream-contents dup >array swap string? ] unit-test
[ B{ 121 120 } 0 ] [
B{ 0 121 120 0 0 0 0 0 0 } binary
0 seek-end input-stream get stream-seek
read1
] with-byte-reader
-] unit-test
\ No newline at end of file
+] unit-test
[ "hello world" ] [
"hello world" "test.txt" temp-file ascii set-file-contents
- "test.txt" temp-file "rb" fopen <c-reader> contents
+ "test.txt" temp-file "rb" fopen <c-reader> stream-contents
>string
] unit-test
[ i>> ] [ underlying>> ] bi ; inline
: next ( stream -- )
- [ 1+ ] change-i drop ; inline
+ [ 1 + ] change-i drop ; inline
: sequence-read1 ( stream -- elt/f )
[ >sequence-stream< ?nth ] [ next ] bi ; inline
M: growable stream-write push-all ;
M: growable stream-flush drop ;
-INSTANCE: growable plain-writer
\ No newline at end of file
+INSTANCE: growable plain-writer
! Regression
: (loop) ( a b c d -- )
[ pick ] dip swap [ pick ] dip swap
- < [ [ 1+ ] 3dip (loop) ] [ 2drop 2drop ] if ; inline recursive
+ < [ [ 1 + ] 3dip (loop) ] [ 2drop 2drop ] if ; inline recursive
: loop ( obj -- )
H{ } values swap [ dup length swap ] dip 0 -roll (loop) ;
cell-bits (first-bignum) ; inline
: most-positive-fixnum ( -- n )
- first-bignum 1- ; inline
+ first-bignum 1 - ; inline
: most-negative-fixnum ( -- n )
first-bignum neg ; inline
: (max-array-capacity) ( b -- n )
- 5 - 2^ 1- ; inline
+ 5 - 2^ 1 - ; inline
: max-array-capacity ( -- n )
cell-bits (max-array-capacity) ; inline
bootstrap-cell-bits (first-bignum) ;
: bootstrap-most-positive-fixnum ( -- n )
- bootstrap-first-bignum 1- ;
+ bootstrap-first-bignum 1 - ;
: bootstrap-most-negative-fixnum ( -- n )
bootstrap-first-bignum neg ;
: next-line ( lexer -- )
dup [ line>> ] [ text>> ] bi ?nth >>line-text
dup line-text>> length >>line-length
- [ 1+ ] change-line
+ [ 1 + ] change-line
0 >>column
drop ;
M: lexer skip-word ( lexer -- )
[
- 2dup nth CHAR: " eq? [ drop 1+ ] [ f skip ] if
+ 2dup nth CHAR: " eq? [ drop 1 + ] [ f skip ] if
] change-lexer-column ;
: still-parsing? ( lexer -- ? )
[ BIN: 11111111111000000000000000000000000000000000000000000000000000 bits>double ]
unit-test
-[ 2.0 ] [ 1.0 1+ ] unit-test
-[ 0.0 ] [ 1.0 1- ] unit-test
+[ 2.0 ] [ 1.0 1 + ] unit-test
+[ 0.0 ] [ 1.0 1 - ] unit-test
[ t ] [ 0.0 zero? ] unit-test
[ t ] [ -0.0 zero? ] unit-test
[ 2. ] [ 2 1 ratio>float ] unit-test
[ .5 ] [ 1 2 ratio>float ] unit-test
[ .75 ] [ 3 4 ratio>float ] unit-test
-[ 1. ] [ 2000 2^ 2000 2^ 1+ ratio>float ] unit-test
-[ -1. ] [ 2000 2^ neg 2000 2^ 1+ ratio>float ] unit-test
+[ 1. ] [ 2000 2^ 2000 2^ 1 + ratio>float ] unit-test
+[ -1. ] [ 2000 2^ neg 2000 2^ 1 + ratio>float ] unit-test
[ 0.4 ] [ 6 15 ratio>float ] unit-test
[ HEX: 3fe553522d230931 ]
M: fixnum bit? neg shift 1 bitand 0 > ;
: fixnum-log2 ( x -- n )
- 0 swap [ dup 1 eq? ] [ [ 1+ ] [ 2/ ] bi* ] until drop ;
+ 0 swap [ dup 1 eq? ] [ [ 1 + ] [ 2/ ] bi* ] until drop ;
M: fixnum (log2) fixnum-log2 ;
! provided with absolutely no warranty."
! First step: pre-scaling
-: twos ( x -- y ) dup 1- bitxor log2 ; inline
+: twos ( x -- y ) dup 1 - bitxor log2 ; inline
: scale-denonimator ( den -- scaled-den scale' )
dup twos neg [ shift ] keep ; inline
! Second step: loop
: shift-mantissa ( scale mantissa -- scale' mantissa' )
- [ 1+ ] [ 2/ ] bi* ; inline
+ [ 1 + ] [ 2/ ] bi* ; inline
: /f-loop ( scale mantissa den -- scale' fraction-and-guard rem )
[ 2dup /i log2 53 > ]
! Third step: post-scaling
: unscaled-float ( mantissa -- n )
- 52 2^ 1- bitand 1022 52 shift bitor bits>double ; inline
+ 52 2^ 1 - bitand 1022 52 shift bitor bits>double ; inline
: scale-float ( scale mantissa -- float' )
[ dup 0 < [ neg 2^ recip ] [ 2^ ] if ] dip * ; inline
] [
pre-scale
/f-loop over odd?
- [ zero? [ 1+ ] unless ] [ drop ] if
+ [ zero? [ 1 + ] unless ] [ drop ] if
post-scale
] if
] if ; inline
: neg ( x -- -x ) 0 swap - ; inline
: recip ( x -- y ) 1 swap / ; inline
: sgn ( x -- n ) dup 0 < [ drop -1 ] [ 0 > 1 0 ? ] if ; inline
-: ?1+ ( x -- y ) [ 1+ ] [ 0 ] if* ; inline
+: ?1+ ( x -- y ) [ 1 + ] [ 0 ] if* ; inline
: rem ( x y -- z ) abs [ mod ] [ + ] [ mod ] tri ; foldable
: 2^ ( n -- 2^n ) 1 swap shift ; inline
: even? ( n -- ? ) 1 bitand zero? ;
] if ;
: next-power-of-2 ( m -- n )
- dup 2 <= [ drop 2 ] [ 1- log2 1+ 2^ ] if ; inline
+ dup 2 <= [ drop 2 ] [ 1 - log2 1 + 2^ ] if ; inline
: power-of-2? ( n -- ? )
- dup 0 <= [ drop f ] [ dup 1- bitand zero? ] if ; foldable
+ dup 0 <= [ drop f ] [ dup 1 - bitand zero? ] if ; foldable
: align ( m w -- n )
- 1- [ + ] keep bitnot bitand ; inline
+ 1 - [ + ] keep bitnot bitand ; inline
<PRIVATE
#! Apply quot to i, keep i and quot, hide n.
[ nip call ] 3keep ; inline
-: iterate-next ( i n quot -- i' n quot ) [ 1+ ] 2dip ; inline
+: iterate-next ( i n quot -- i' n quot ) [ 1 + ] 2dip ; inline
PRIVATE>
[ call ] 2keep rot [
drop
] [
- [ 1- ] dip find-last-integer
+ [ 1 - ] dip find-last-integer
] if
] if ; inline recursive
: inc ( variable -- ) 1 swap +@ ; inline
: dec ( variable -- ) -1 swap +@ ; inline
: bind ( ns quot -- ) swap >n call ndrop ; inline
-: counter ( variable -- n ) [ 0 or 1+ dup ] change-global ;
+: counter ( variable -- n ) [ 0 or 1 + dup ] change-global ;
: make-assoc ( quot exemplar -- hash ) 20 swap new-assoc [ swap bind ] keep ; inline
: with-scope ( quot -- ) 5 <hashtable> swap bind ; inline
: with-variable ( value key quot -- ) [ associate ] dip bind ; inline
-: initialize ( variable quot -- ) [ unless* ] curry change-global ; inline
\ No newline at end of file
+: initialize ( variable quot -- ) [ unless* ] curry change-global ; inline
: parse-stream ( stream name -- quot )
[
[
- lines dup parse-fresh
+ stream-lines dup parse-fresh
[ nip ] [ finish-parsing ] 2bi
forget-smudged
] with-source-file
M: wrapper literalize <wrapper> ;
-M: curry length quot>> length 1+ ;
+M: curry length quot>> length 1 + ;
M: curry nth
over 0 =
[ nip obj>> literalize ]
- [ [ 1- ] dip quot>> nth ]
+ [ [ 1 - ] dip quot>> nth ]
if ;
INSTANCE: curry immutable-sequence
M: reversed virtual-seq seq>> ;
-M: reversed virtual@ seq>> [ length swap - 1- ] keep ;
+M: reversed virtual@ seq>> [ length swap - 1 - ] keep ;
M: reversed length seq>> length ;
] 3keep ; inline
: (copy) ( dst i src j n -- dst )
- dup 0 <= [ 2drop 2drop ] [ 1- ((copy)) (copy) ] if ;
+ dup 0 <= [ 2drop 2drop ] [ 1 - ((copy)) (copy) ] if ;
inline recursive
: prepare-subseq ( from to seq -- dst i src j n )
[ nip find-last-integer ] (find-from) ; inline
: find-last ( seq quot -- i elt )
- [ [ 1- ] dip find-last-integer ] (find) ; inline
+ [ [ 1 - ] dip find-last-integer ] (find) ; inline
: all? ( seq quot -- ? )
(each) all-integers? ; inline
[ empty? not ] filter ;
: mismatch ( seq1 seq2 -- i )
- [ min-length ] 2keep
+ [ min-length iota ] 2keep
[ 2nth-unsafe = not ] 2curry
find drop ; inline
: (filter-here) ( quot: ( elt -- ? ) store scan seq -- )
2dup length < [
[ move ] 3keep
- [ nth-unsafe pick call [ 1+ ] when ] 2keep
- [ 1+ ] dip
+ [ nth-unsafe pick call [ 1 + ] when ] 2keep
+ [ 1 + ] dip
(filter-here)
] [ nip set-length drop ] if ; inline recursive
[ eq? not ] with filter-here ;
: prefix ( seq elt -- newseq )
- over [ over length 1+ ] dip [
+ over [ over length 1 + ] dip [
[ 0 swap set-nth-unsafe ] keep
[ 1 swap copy ] keep
] new-like ;
: suffix ( seq elt -- newseq )
- over [ over length 1+ ] dip [
+ over [ over length 1 + ] dip [
[ [ over length ] dip set-nth-unsafe ] keep
[ 0 swap copy ] keep
] new-like ;
-: peek ( seq -- elt ) [ length 1- ] [ nth ] bi ;
+: peek ( seq -- elt ) [ length 1 - ] [ nth ] bi ;
-: pop* ( seq -- ) [ length 1- ] [ shorten ] bi ;
+: pop* ( seq -- ) [ length 1 - ] [ shorten ] bi ;
<PRIVATE
2over = [
2drop 2drop
] [
- [ [ 2over + pick ] dip move [ 1+ ] dip ] keep
+ [ [ 2over + pick ] dip move [ 1 + ] dip ] keep
move-backward
] if ;
2over = [
2drop 2drop
] [
- [ [ pick [ dup dup ] dip + swap ] dip move 1- ] keep
+ [ [ pick [ dup dup ] dip + swap ] dip move 1 - ] keep
move-forward
] if ;
: (open-slice) ( shift from to seq ? -- )
[
- [ [ 1- ] bi@ ] dip move-forward
+ [ [ 1 - ] bi@ ] dip move-forward
] [
[ over - ] 2dip move-backward
] if ;
check-slice [ over [ - ] dip ] dip open-slice ;
: delete-nth ( n seq -- )
- [ dup 1+ ] dip delete-slice ;
+ [ dup 1 + ] dip delete-slice ;
: snip ( from to seq -- head tail )
[ swap head ] [ swap tail ] bi-curry bi* ; inline
snip-slice surround ;
: remove-nth ( n seq -- seq' )
- [ [ { } ] dip dup 1+ ] dip replace-slice ;
+ [ [ { } ] dip dup 1 + ] dip replace-slice ;
: pop ( seq -- elt )
- [ length 1- ] [ [ nth ] [ shorten ] 2bi ] bi ;
+ [ length 1 - ] [ [ nth ] [ shorten ] 2bi ] bi ;
: exchange ( m n seq -- )
[ nip bounds-check 2drop ]
: reverse-here ( seq -- )
[ length 2/ ] [ length ] [ ] tri
- [ [ over - 1- ] dip exchange-unsafe ] 2curry each ;
+ [ [ over - 1 - ] dip exchange-unsafe ] 2curry each ;
: reverse ( seq -- newseq )
[
PRIVATE>
: start* ( subseq seq n -- i )
- pick length pick length swap - 1+
+ pick length pick length swap - 1 +
[ (start) ] find-from
swap [ 3drop ] dip ;
[ [ [ 2drop ] dip nth-unsafe ] dip push ] [
pick 2 = [
[
- [ 2drop dup 1+ ] dip
+ [ 2drop dup 1 + ] dip
[ nth-unsafe ] curry bi@
] dip [ push ] curry bi@
] [
pick 3 = [
[
- [ 2drop dup 1+ dup 1+ ] dip
+ [ 2drop dup 1 + dup 1 + ] dip
[ nth-unsafe ] curry tri@
] dip [ push ] curry tri@
] [ [ nip subseq ] dip push-all ] if
[ [ from2>> ] [ to2>> ] [ seq>> ] tri ] [ accum>> ] bi dump ; inline
: l-next ( merge -- )
- [ [ l-elt ] [ [ 1+ ] change-from1 drop ] bi ] [ accum>> ] bi push ; inline
+ [ [ l-elt ] [ [ 1 + ] change-from1 drop ] bi ] [ accum>> ] bi push ; inline
: r-next ( merge -- )
- [ [ r-elt ] [ [ 1+ ] change-from2 drop ] bi ] [ accum>> ] bi push ; inline
+ [ [ r-elt ] [ [ 1 + ] change-from2 drop ] bi ] [ accum>> ] bi push ; inline
: decide ( merge -- ? )
[ [ l-elt ] [ r-elt ] bi ] dip call +gt+ eq? ; inline
while 2drop ; inline
: each-pair ( seq quot -- )
- [ [ length 1+ 2/ ] keep ] dip
- [ [ 1 shift dup 1+ ] dip ] prepose curry each-integer ; inline
+ [ [ length 1 + 2/ ] keep ] dip
+ [ [ 1 shift dup 1 + ] dip ] prepose curry each-integer ; inline
: (sort-pairs) ( i1 i2 seq quot accum -- )
[ 2dup length = ] 2dip rot [
: (split) ( separators n seq -- )
3dup rot [ member? ] curry find-from drop
- [ [ swap subseq , ] 2keep 1+ swap (split) ]
+ [ [ swap subseq , ] 2keep 1 + swap (split) ]
[ swap dup zero? [ drop ] [ tail ] if , drop ] if* ; inline recursive
: split, ( seq separators -- ) 0 rot (split) ;
"<PRIVATE"
""
": (fac) ( accum n -- n! )"
- " dup 1 <= [ drop ] [ [ * ] keep 1- (fac) ] if ;"
+ " dup 1 <= [ drop ] [ [ * ] keep 1 - (fac) ] if ;"
""
"PRIVATE>"
""
"IN: factorial.private"
""
": (fac) ( accum n -- n! )"
- " dup 1 <= [ drop ] [ [ * ] keep 1- (fac) ] if ;"
+ " dup 1 <= [ drop ] [ [ * ] keep 1 - (fac) ] if ;"
""
"IN: factorial"
""
--- /dev/null
+Sascha Matzke
--- /dev/null
+Sascha Matzke
--- /dev/null
+Shared constants and classes
--- /dev/null
+Sascha Matzke
--- /dev/null
+BSON to Factor deserializer
--- /dev/null
+BSON reader and writer
--- /dev/null
+Sascha Matzke
--- /dev/null
+Factor to BSON serializer
USING: accessors arrays bunny.cel-shaded bunny.fixed-pipeline
bunny.model bunny.outlined destructors kernel math opengl.demo-support
opengl.gl sequences ui ui.gadgets ui.gadgets.worlds ui.gestures
-ui.render words ;
+ui.render words ui.pixel-formats ;
IN: bunny
-TUPLE: bunny-gadget < demo-gadget model-triangles geom draw-seq draw-n ;
+TUPLE: bunny-world < demo-world model-triangles geom draw-seq draw-n ;
-: <bunny-gadget> ( -- bunny-gadget )
- 0.0 0.0 0.375 bunny-gadget new-demo-gadget
- maybe-download read-model >>model-triangles ;
-
-: bunny-gadget-draw ( gadget -- draw )
+: get-draw ( gadget -- draw )
[ draw-n>> ] [ draw-seq>> ] bi nth ;
-: bunny-gadget-next-draw ( gadget -- )
+: next-draw ( gadget -- )
dup [ draw-seq>> ] [ draw-n>> ] bi
1+ swap length mod
>>draw-n relayout-1 ;
-M: bunny-gadget graft* ( gadget -- )
- dup find-gl-context
- GL_DEPTH_TEST glEnable
- dup model-triangles>> <bunny-geom> >>geom
- dup
+: make-draws ( gadget -- draw-seq )
[ <bunny-fixed-pipeline> ]
[ <bunny-cel-shaded> ]
[ <bunny-outlined> ] tri 3array
- sift >>draw-seq
+ sift ;
+
+M: bunny-world begin-world
+ GL_DEPTH_TEST glEnable
+ 0.0 0.0 0.375 set-demo-orientation
+ maybe-download read-model
+ [ >>model-triangles ] [ <bunny-geom> >>geom ] bi
+ dup make-draws >>draw-seq
0 >>draw-n
drop ;
-M: bunny-gadget ungraft* ( gadget -- )
+M: bunny-world end-world
dup find-gl-context
[ geom>> [ dispose ] when* ]
[ draw-seq>> [ [ dispose ] when* ] each ] bi ;
-M: bunny-gadget draw-gadget* ( gadget -- )
+M: bunny-world draw-world*
dup draw-seq>> empty? [ drop ] [
0.15 0.15 0.15 1.0 glClearColor
GL_DEPTH_BUFFER_BIT GL_COLOR_BUFFER_BIT bitor glClear
- dup demo-gadget-set-matrices
+ dup demo-world-set-matrix
GL_MODELVIEW glMatrixMode
0.02 -0.105 0.0 glTranslatef
- [ geom>> ] [ bunny-gadget-draw ] bi draw-bunny
+ [ geom>> ] [ get-draw ] bi draw-bunny
] if ;
-M: bunny-gadget pref-dim* ( gadget -- dim )
+M: bunny-world pref-dim* ( gadget -- dim )
drop { 640 480 } ;
-bunny-gadget H{
- { T{ key-down f f "TAB" } [ bunny-gadget-next-draw ] }
+bunny-world H{
+ { T{ key-down f f "TAB" } [ next-draw ] }
} set-gestures
: bunny-window ( -- )
- [ <bunny-gadget> "Bunny" open-window ] with-ui ;
+ [
+ f T{ world-attributes
+ { world-class bunny-world }
+ { title "Bunny" }
+ { pixel-format-attributes {
+ windowed
+ double-buffered
+ T{ depth-bits { value 16 } }
+ } }
+ } open-window
+ ] with-ui ;
MAIN: bunny-window
] with-framebuffer ;
: (pass2) ( draw -- )
- init-matrices {
+ GL_PROJECTION glMatrixMode
+ glPushMatrix glLoadIdentity
+ GL_MODELVIEW glMatrixMode
+ glLoadIdentity
+ {
[ color-texture>> GL_TEXTURE_2D GL_TEXTURE0 bind-texture-unit ]
[ normal-texture>> GL_TEXTURE_2D GL_TEXTURE1 bind-texture-unit ]
[ depth-texture>> GL_TEXTURE_2D GL_TEXTURE2 bind-texture-unit ]
} cleave { -1.0 -1.0 } { 1.0 1.0 } rect-vertices
] with-gl-program
]
- } cleave ;
+ } cleave
+ GL_PROJECTION glMatrixMode
+ glPopMatrix ;
M: bunny-outlined draw-bunny
[ remake-framebuffer-if-needed ]
: changelog ( -- authors )
image parent-directory [
- "git log --pretty=format:%an" ascii <process-reader> lines
+ "git log --pretty=format:%an" ascii <process-reader> stream-lines
] with-directory ;
: patch-counts ( authors -- assoc )
--- /dev/null
+USING: kernel file-trees ;
+IN: file-trees.tests
+{ "/sample/1" "/sample/2" "/killer/1" "/killer/2/3"
+"/killer/2/4" "/killer/2/4/6" "/megakiller" } create-tree drop
\ No newline at end of file
--- /dev/null
+USING: accessors arrays delegate delegate.protocols
+io.pathnames kernel locals namespaces prettyprint sequences
+ui.frp vectors ;
+IN: file-trees
+
+TUPLE: tree node children ;
+CONSULT: sequence-protocol tree children>> ;
+
+: <tree> ( start -- tree ) V{ } clone
+ [ tree boa dup children>> ] [ ".." swap tree boa ] bi swap push ;
+
+DEFER: (tree-insert)
+
+: tree-insert ( path tree -- ) [ unclip <tree> ] [ children>> ] bi* (tree-insert) ;
+:: (tree-insert) ( path-rest path-head tree-children -- )
+ tree-children [ node>> path-head node>> = ] find nip
+ [ path-rest swap tree-insert ]
+ [
+ path-head tree-children push
+ path-rest [ path-head tree-insert ] unless-empty
+ ] if* ;
+: create-tree ( file-list -- tree ) [ path-components ] map
+ t <tree> [ [ tree-insert ] curry each ] keep ;
+
+: <dir-table> ( tree-model -- table )
+ <frp-list*> [ node>> 1array ] >>quot
+ [ selected-value>> <switch> ]
+ [ swap >>model ] bi ;
\ No newline at end of file
"--pretty=format:%h %an: %s" ,
".." glue ,
] { } make
- latin1 [ input-stream get lines ] with-process-reader ;
+ latin1 [ lines ] with-process-reader ;
: updates ( from to -- lines )
git-log reverse
+++ /dev/null
-! Copyright (C) 2008 Joe Groff.
-! See http://factorcode.org/license.txt for BSD license.
-USING: help.markup help.syntax kernel multiline ;
-IN: literals
-
-HELP: $
-{ $syntax "$ word" }
-{ $description "Executes " { $snippet "word" } " at parse time and adds the result(s) to the parser accumulator." }
-{ $notes { $snippet "word" } "'s definition is looked up and " { $link call } "ed at parse time, so words that reference words in the current compilation unit cannot be used with " { $snippet "$" } "." }
-{ $examples
-
- { $example <"
-USING: kernel literals prettyprint ;
-IN: scratchpad
-
-CONSTANT: five 5
-{ $ five } .
- "> "{ 5 }" }
-
- { $example <"
-USING: kernel literals prettyprint ;
-IN: scratchpad
-
-<< : seven-eleven ( -- a b ) 7 11 ; >>
-{ $ seven-eleven } .
- "> "{ 7 11 }" }
-
-} ;
-
-HELP: $[
-{ $syntax "$[ code ]" }
-{ $description "Calls " { $snippet "code" } " at parse time and adds the result(s) to the parser accumulator." }
-{ $notes "Since " { $snippet "code" } " is " { $link call } "ed at parse time, it cannot reference any words defined in the same compilation unit." }
-{ $examples
-
- { $example <"
-USING: kernel literals math prettyprint ;
-IN: scratchpad
-
-<< CONSTANT: five 5 >>
-{ $[ five dup 1+ dup 2 + ] } .
- "> "{ 5 6 8 }" }
-
-} ;
-
-{ POSTPONE: $ POSTPONE: $[ } related-words
-
-ARTICLE: "literals" "Interpolating code results into literal values"
-"The " { $vocab-link "literals" } " vocabulary contains words to run code at parse time and insert the results into more complex literal values."
-{ $example <"
-USING: kernel literals math prettyprint ;
-IN: scratchpad
-
-<< CONSTANT: five 5 >>
-{ $ five $[ five dup 1+ dup 2 + ] } .
- "> "{ 5 5 6 8 }" }
-{ $subsection POSTPONE: $ }
-{ $subsection POSTPONE: $[ }
-;
-
-ABOUT: "literals"
+++ /dev/null
-USING: kernel literals math tools.test ;
-IN: literals.tests
-
-<<
-: six-six-six ( -- a b c ) 6 6 6 ;
->>
-
-: five ( -- a ) 5 ;
-: seven-eleven ( -- b c ) 7 11 ;
-
-[ { 5 } ] [ { $ five } ] unit-test
-[ { 7 11 } ] [ { $ seven-eleven } ] unit-test
-[ { 6 6 6 } ] [ { $ six-six-six } ] unit-test
-
-[ { 6 6 6 7 } ] [ { $ six-six-six 7 } ] unit-test
-
-[ { 8 8 8 } ] [ { $[ six-six-six [ 2 + ] tri@ ] } ] unit-test
-
-[ { 0.5 2.0 } ] [ { $[ 1.0 2.0 / ] 2.0 } ] unit-test
-
-[ { 1.0 { 0.5 1.5 } 4.0 } ] [ { 1.0 { $[ 1.0 2.0 / ] 1.5 } $[ 2.0 2.0 * ] } ] unit-test
+++ /dev/null
-! (c) Joe Groff, see license for details
-USING: accessors continuations kernel parser words quotations vectors ;
-IN: literals
-
-SYNTAX: $ scan-word [ def>> call ] curry with-datastack >vector ;
-SYNTAX: $[ parse-quotation with-datastack >vector ;
+++ /dev/null
-Expression interpolation into sequence literals
+++ /dev/null
-extensions
-syntax
: try-output-process ( command -- )
>process +stdout+ >>stderr utf8 <process-reader*>
- [ contents ] [ dup wait-for-process ] bi*
+ [ stream-contents ] [ dup wait-for-process ] bi*
0 = [ 2drop ] [ output-process-error ] if ;
HOOK: really-delete-tree os ( path -- )
--- /dev/null
+Sascha Matzke
--- /dev/null
+Sascha Matzke
--- /dev/null
+serialization/deserialization and insert/query benchmarks for mongodb.driver
--- /dev/null
+Sascha Matzke
--- /dev/null
+low-level connection handling for mongodb.driver
}
{ $description "executes a quotation with the given mdb instance in its context" } ;
-ARTICLE: "mongodb.driver" "MongoDB factor driver"
-{ $vocab-link "mongodb.driver" }
-;
-
-ABOUT: "mongodb.driver"
--- /dev/null
+Sascha Matzke
--- /dev/null
+mongo-message-monitor - a small proxy to introspect messages send to MongoDB
--- /dev/null
+USING: assocs help.markup help.syntax kernel quotations ;
+IN: mongodb
+
+ARTICLE: "mongodb" "MongoDB factor integration"
+"The " { $vocab-link "mongodb" } " vocabulary provides two different interfaces to the MongoDB document-oriented database"
+{ $heading "Low-level driver" }
+"The " { $vocab-link "mongodb.driver" } " vocabulary provides a low-level interface to MongoDB."
+{ $unchecked-example
+ "USING: mongodb.driver ;"
+ "\"db\" \"127.0.0.1\" 27017 <mdb>"
+ "[ \"mycollection\" [ H{ { \"name\" \"Alfred\" } { \"age\" 57 } } save ] "
+ " [ ageIdx [ \"age\" asc ] key-spec <index-spec> ensure-index ]"
+ " [ H{ { \"age\" H{ { \"$gt\" 50 } } } } <query> find-one ] tri ] with-db "
+ "" }
+{ $heading "Highlevel tuple integration" }
+"The " { $vocab-link "mongodb.tuple" } " vocabulary lets you define persistent tuples that can be stored to and retrieved from a MongoDB database"
+{ $unchecked-example
+ "USING: mongodb.driver mongodb.tuple fry ;"
+ "MDBTUPLE: person name age ; "
+ "person \"persons\" { { \"age\" +fieldindex+ } } define-persistent "
+ "\"db\" \"127.0.0.1\" 27017 <mdb>"
+ "person new \"Alfred\" >>name 57 >>age"
+ "'[ _ save-tuple person new 57 >>age select-tuple ] with-db"
+ "" }
+;
+
+ABOUT: "mongodb"
\ No newline at end of file
--- /dev/null
+USING: vocabs.loader ;
+
+IN: mongodb
+
+"mongodb.connection" require
+"mongodb.driver" require
+"mongodb.tuple" require
+
--- /dev/null
+Sascha Matzke
--- /dev/null
+message primitives for the communication with MongoDB
--- /dev/null
+Sascha Matzke
--- /dev/null
+low-level message reading and writing
--- /dev/null
+MongoDB Factor integration
--- /dev/null
+Sascha Matzke
--- /dev/null
+Sascha Matzke
--- /dev/null
+tuple class MongoDB collection handling
--- /dev/null
+Sascha Matzke
--- /dev/null
+tuple class index handling
--- /dev/null
+Sascha Matzke
--- /dev/null
+tuple to MongoDB storable conversion (and back)
--- /dev/null
+Sascha Matzke
--- /dev/null
+client-side persistent tuple state handling
--- /dev/null
+persist tuple instances into MongoDB
USING: arrays kernel math math.functions math.order math.vectors
namespaces opengl opengl.gl sequences ui ui.gadgets ui.gestures
-ui.render accessors combinators ;
+ui.gadgets.worlds ui.render accessors combinators ;
IN: opengl.demo-support
: FOV ( -- x ) 2.0 sqrt 1+ ; inline
SYMBOL: last-drag-loc
-TUPLE: demo-gadget < gadget yaw pitch distance ;
+TUPLE: demo-world < world yaw pitch distance ;
-: new-demo-gadget ( yaw pitch distance class -- gadget )
- new
- swap >>distance
- swap >>pitch
- swap >>yaw ; inline
+: set-demo-orientation ( world yaw pitch distance -- world )
+ [ >>yaw ] [ >>pitch ] [ >>distance ] tri* ;
GENERIC: far-plane ( gadget -- z )
GENERIC: near-plane ( gadget -- z )
GENERIC: distance-step ( gadget -- dz )
-M: demo-gadget far-plane ( gadget -- z )
+M: demo-world far-plane ( gadget -- z )
drop 4.0 ;
-M: demo-gadget near-plane ( gadget -- z )
+M: demo-world near-plane ( gadget -- z )
drop 1.0 64.0 / ;
-M: demo-gadget distance-step ( gadget -- dz )
+M: demo-world distance-step ( gadget -- dz )
drop 1.0 64.0 / ;
: fov-ratio ( gadget -- fov ) dim>> dup first2 min v/n ;
-: yaw-demo-gadget ( yaw gadget -- )
+: yaw-demo-world ( yaw gadget -- )
[ + ] with change-yaw relayout-1 ;
-: pitch-demo-gadget ( pitch gadget -- )
+: pitch-demo-world ( pitch gadget -- )
[ + ] with change-pitch relayout-1 ;
-: zoom-demo-gadget ( distance gadget -- )
+: zoom-demo-world ( distance gadget -- )
[ + ] with change-distance relayout-1 ;
-M: demo-gadget pref-dim* ( gadget -- dim )
+M: demo-world focusable-child* ( world -- gadget )
+ drop t ;
+
+M: demo-world pref-dim* ( gadget -- dim )
drop { 640 480 } ;
: -+ ( x -- -x x )
[ neg ] keep ;
-: demo-gadget-frustum ( gadget -- -x x -y y near far )
+: demo-world-frustum ( world -- -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 -- )
+M: demo-world resize-world
+ GL_PROJECTION glMatrixMode
+ glLoadIdentity
+ [ [ 0 0 ] dip dim>> first2 glViewport ]
+ [ demo-world-frustum glFrustum ] bi ;
+
+: demo-world-set-matrix ( gadget -- )
GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT bitor glClear
- [
- GL_PROJECTION glMatrixMode
- glLoadIdentity
- demo-gadget-frustum glFrustum
- ] [
- GL_MODELVIEW glMatrixMode
- glLoadIdentity
- [ [ 0.0 0.0 ] dip distance>> neg glTranslatef ]
- [ pitch>> 1.0 0.0 0.0 glRotatef ]
- [ yaw>> 0.0 1.0 0.0 glRotatef ]
- tri
- ] bi ;
+ GL_MODELVIEW glMatrixMode
+ glLoadIdentity
+ [ [ 0.0 0.0 ] dip distance>> neg glTranslatef ]
+ [ pitch>> 1.0 0.0 0.0 glRotatef ]
+ [ yaw>> 0.0 1.0 0.0 glRotatef ]
+ tri ;
: reset-last-drag-rel ( -- )
{ 0 0 } last-drag-loc set-global ;
swap first swap second glVertex2d
] do-state ;
-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 ] }
+demo-world H{
+ { T{ key-down f f "LEFT" } [ KEY-ROTATE-STEP neg swap yaw-demo-world ] }
+ { T{ key-down f f "RIGHT" } [ KEY-ROTATE-STEP swap yaw-demo-world ] }
+ { T{ key-down f f "DOWN" } [ KEY-ROTATE-STEP neg swap pitch-demo-world ] }
+ { T{ key-down f f "UP" } [ KEY-ROTATE-STEP swap pitch-demo-world ] }
+ { T{ key-down f f "=" } [ dup distance-step neg swap zoom-demo-world ] }
+ { T{ key-down f f "-" } [ dup distance-step swap zoom-demo-world ] }
{ 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 ] }
- { mouse-scroll [ scroll-direction get second over distance-step * swap zoom-demo-gadget ] }
+ { T{ drag f 1 } [ drag-yaw-pitch rot [ pitch-demo-world ] keep yaw-demo-world ] }
+ { mouse-scroll [ scroll-direction get second over distance-step * swap zoom-demo-world ] }
} set-gestures
USING: kernel opengl opengl.demo-support opengl.gl opengl.textures
opengl.shaders opengl.framebuffers opengl.capabilities multiline
ui.gadgets accessors sequences ui.render ui math locals arrays
-generalizations combinators ui.gadgets.worlds ;
+generalizations combinators ui.gadgets.worlds
+literals ui.pixel-formats ;
IN: spheres
STRING: plane-vertex-shader
}
;
-TUPLE: spheres-gadget < demo-gadget
+TUPLE: spheres-world < demo-world
plane-program solid-sphere-program texture-sphere-program
reflection-framebuffer reflection-depthbuffer
- reflection-texture initialized? ;
+ reflection-texture ;
-: <spheres-gadget> ( -- gadget )
- 20.0 10.0 20.0 spheres-gadget new-demo-gadget ;
-
-M: spheres-gadget near-plane ( gadget -- z )
+M: spheres-world near-plane ( gadget -- z )
drop 1.0 ;
-M: spheres-gadget far-plane ( gadget -- z )
+M: spheres-world far-plane ( gadget -- z )
drop 512.0 ;
-M: spheres-gadget distance-step ( gadget -- dz )
+M: spheres-world distance-step ( gadget -- dz )
drop 0.5 ;
: (reflection-dim) ( -- w h )
GL_TEXTURE_CUBE_MAP GL_TEXTURE_WRAP_S GL_CLAMP glTexParameteri
GL_TEXTURE_CUBE_MAP GL_TEXTURE_WRAP_T GL_CLAMP glTexParameteri
GL_TEXTURE_CUBE_MAP GL_TEXTURE_WRAP_R GL_CLAMP glTexParameteri
- GL_TEXTURE_CUBE_MAP_POSITIVE_X
- GL_TEXTURE_CUBE_MAP_POSITIVE_Y
- GL_TEXTURE_CUBE_MAP_POSITIVE_Z
- GL_TEXTURE_CUBE_MAP_NEGATIVE_X
- GL_TEXTURE_CUBE_MAP_NEGATIVE_Y
- GL_TEXTURE_CUBE_MAP_NEGATIVE_Z 6 narray
+ ${
+ GL_TEXTURE_CUBE_MAP_POSITIVE_X
+ GL_TEXTURE_CUBE_MAP_POSITIVE_Y
+ GL_TEXTURE_CUBE_MAP_POSITIVE_Z
+ GL_TEXTURE_CUBE_MAP_NEGATIVE_X
+ GL_TEXTURE_CUBE_MAP_NEGATIVE_Y
+ GL_TEXTURE_CUBE_MAP_NEGATIVE_Z
+ }
[ 0 GL_RGBA8 (reflection-dim) 0 GL_RGBA GL_UNSIGNED_BYTE f glTexImage2D ]
each
] keep ;
sphere-main-fragment-shader <fragment-shader> check-gl-shader
3array <gl-program> check-gl-program ;
-M: spheres-gadget graft* ( gadget -- )
- dup find-gl-context
+M: spheres-world begin-world
"2.0" { "GL_ARB_shader_objects" } require-gl-version-or-extensions
{ "GL_EXT_framebuffer_object" } require-gl-extensions
+ 20.0 10.0 20.0 set-demo-orientation
(plane-program) >>plane-program
(solid-sphere-program) >>solid-sphere-program
(texture-sphere-program) >>texture-sphere-program
(make-reflection-texture) >>reflection-texture
(make-reflection-depthbuffer) [ >>reflection-depthbuffer ] keep
(make-reflection-framebuffer) >>reflection-framebuffer
- t >>initialized?
drop ;
-M: spheres-gadget ungraft* ( gadget -- )
- f >>initialized?
- dup find-gl-context
+M: spheres-world end-world
{
[ reflection-framebuffer>> [ delete-framebuffer ] when* ]
[ reflection-depthbuffer>> [ delete-renderbuffer ] when* ]
[ plane-program>> [ delete-gl-program ] when* ]
} cleave ;
-M: spheres-gadget pref-dim* ( gadget -- dim )
+M: spheres-world pref-dim* ( gadget -- dim )
drop { 640 480 } ;
:: (draw-sphere) ( program center radius -- )
[ drop 0 0 (reflection-dim) glViewport ]
[
GL_PROJECTION glMatrixMode
- glLoadIdentity
+ glPushMatrix glLoadIdentity
reflection-frustum glFrustum
GL_MODELVIEW glMatrixMode
glLoadIdentity
[ GL_TEXTURE_CUBE_MAP_POSITIVE_Y (reflection-face)
glPopMatrix 90.0 1.0 0.0 0.0 glRotatef ]
[ sphere-scene ]
- [ dim>> 0 0 rot first2 glViewport ]
+ [
+ [ 0 0 ] dip dim>> first2 glViewport
+ GL_PROJECTION glMatrixMode
+ glPopMatrix
+ ]
} cleave ] with-framebuffer ;
-: (draw-gadget) ( gadget -- )
+M: spheres-world draw-world*
GL_DEPTH_TEST glEnable
GL_SCISSOR_TEST glDisable
0.15 0.15 1.0 1.0 glClearColor {
[ (draw-reflection-texture) ]
- [ demo-gadget-set-matrices ]
+ [ demo-world-set-matrix ]
[ sphere-scene ]
[ reflection-texture>> GL_TEXTURE_CUBE_MAP GL_TEXTURE0 bind-texture-unit ]
[
]
} cleave ;
-M: spheres-gadget draw-gadget* ( gadget -- )
- dup initialized?>> [ (draw-gadget) ] [ drop ] if ;
-
: spheres-window ( -- )
- [ <spheres-gadget> "Spheres" open-window ] with-ui ;
+ [
+ f T{ world-attributes
+ { world-class spheres-world }
+ { title "Spheres" }
+ { pixel-format-attributes {
+ windowed
+ double-buffered
+ T{ depth-bits { value 16 } }
+ } }
+ } open-window
+ ] with-ui ;
MAIN: spheres-window
-USING: kernel sequences splitting strings.parser ;
+USING: combinators effects kernel math sequences splitting
+strings.parser ;
IN: str-fry
-: str-fry ( str -- quot ) "_" split unclip [ [ rot glue ] reduce ] 2curry ;
+: str-fry ( str -- quot ) "_" split
+ [ unclip [ [ rot glue ] reduce ] 2curry ]
+ [ length 1 - 1 <effect> [ call-effect ] 2curry ] bi ;
SYNTAX: I" parse-string rest str-fry over push-all ;
\ No newline at end of file
-USING: ui.frp help.syntax help.markup monads sequences ;
+USING: help.markup help.syntax models monads sequences
+ui.gadgets.buttons ui.gadgets.tracks ;
IN: ui.frp
! Layout utilities
HELP: ,
+{ $values { "uiitem" "a gadget or model" } }
{ $description "Used in a series of gadgets created by a box, accumulating the gadget" } ;
HELP: ->
+{ $values { "uiitem" "a gadget or model" } { "model" model } }
{ $description "Like " { $link , } "but passes its model on for further use." } ;
HELP: <hbox>
+{ $values { "gadgets" "a list of gadgets" } { "track" track } }
{ $syntax "[ gadget , gadget , ... ] <hbox>" }
{ $description "Creates an horizontal track containing the gadgets listed in the quotation" } ;
HELP: <vbox>
+{ $values { "gadgets" "a list of gadgets" } { "track" track } }
{ $syntax "[ gadget , gadget , ... ] <hbox>" }
{ $description "Creates an vertical track containing the gadgets listed in the quotation" } ;
! Gadgets
HELP: <frp-button>
+{ $values { "text" "the button's label" } { "button" button } }
{ $description "Creates an button whose model updates on clicks" } ;
HELP: <merge>
-{ $description "Creates a model that merges the updates of two others" } ;
+{ $values { "models" "a list of models" } { "model" merge-model } }
+{ $description "Creates a model that merges the updates of others" } ;
HELP: <filter>
+{ $values { "model" model } { "quot" "quotation with stack effect ( a b -- c )" } { "filter-model" filter-model } }
{ $description "Creates a model that uses the updates of another model when they satisfy a given predicate" } ;
HELP: <fold>
+{ $values { "oldval" "starting value" } { "quot" "applied to update and previous values" } { "model" model } { "model'" model } }
{ $description "Similar to " { $link reduce } " but works on models, applying a quotation to the previous and new values at each update" } ;
-HELP: switch
+HELP: <switch>
+{ $values { "signal1" model } { "signal2" model } { "signal'" model } }
{ $description "Creates a model that starts with the behavior of model1 and switches to the behavior of model2 on its update" } ;
ARTICLE: { "frp" "instances" } "FRP Instances"
-"Models are all functors, as " { $link fmap } " corresponds directly to the " { $link "models.arrow" } " vocabulary. "
-"Also, a gadget is a monad. Binding recieves a model and creates a new gadget." ;
+"Models are all functors, as " { $link fmap } " corresponds directly to the " { $link "models.arrow" } " vocabulary. "
+"Also, a gadget is a monad. Binding recieves a model and creates a new gadget." ;
-USING: accessors arrays colors fonts fry kernel models
+USING: accessors arrays colors fonts kernel models
models.product monads sequences ui.gadgets ui.gadgets.buttons
ui.gadgets.editors ui.gadgets.line-support ui.gadgets.tables
-ui.gadgets.tracks ui.render ;
+ui.gadgets.tracks ui.render ui.gadgets.scrollers ;
QUALIFIED: make
IN: ui.frp
M: frp-table row-value val-quot>> [ call( a -- b ) ] [ drop f ] if* ;
M: frp-table row-color color-quot>> [ call( a -- b ) ] [ drop f ] if* ;
-: <frp-table> ( model quot -- table )
- frp-table new-line-gadget dup >>renderer swap >>quot swap >>model
+: <frp-table> ( model -- table )
+ frp-table new-line-gadget dup >>renderer [ ] >>quot swap >>model
f <model> >>selected-value sans-serif-font >>font
focus-border-color >>focus-border-color
- transparent >>column-line-color ;
+ transparent >>column-line-color [ ] >>val-quot ;
+: <frp-table*> ( -- table ) f <model> <frp-table> ;
+: <frp-list> ( model -- table ) <frp-table> [ 1array ] >>quot ;
+: <frp-list*> ( -- table ) f <model> <frp-list> ;
+
: <frp-field> ( -- field ) f <model> <model-field> ;
! Layout utilities
GENERIC: output-model ( gadget -- model )
M: gadget output-model model>> ;
M: frp-table output-model selected-value>> ;
+M: model-field output-model field-model>> ;
+M: scroller output-model children>> first model>> ;
-GENERIC: , ( object -- )
+GENERIC: , ( uiitem -- )
M: gadget , make:, ;
M: model , activate-model ;
-GENERIC: -> ( object -- model )
+GENERIC: -> ( uiitem -- model )
M: gadget -> dup make:, output-model ;
M: model -> dup , ;
M: table -> dup , selected-value>> ;
[ { } make:make ] dip <track> swap [ f track-add ] each ; inline
: <box*> ( gadgets type -- track ) [ <box> ] [ [ model>> ] map <product> ] bi >>model ; inline
: <hbox> ( gadgets -- track ) horizontal <box> ; inline
+: <hbox*> ( gadgets -- track ) horizontal <box*> ; inline
: <vbox> ( gadgets -- track ) vertical <box> ; inline
+: <vbox*> ( gadgets -- track ) vertical <box*> ; inline
-! Model utilities
+! !!! Model utilities
TUPLE: multi-model < model ;
-! M: multi-model model-activated dup model-changed ;
: <multi-model> ( models kind -- model ) f swap new-model [ [ add-dependency ] curry each ] keep ;
+! Events- discrete model utilities
+
TUPLE: merge-model < multi-model ;
M: merge-model model-changed [ value>> ] dip set-model ;
: <merge> ( models -- model ) merge-model <multi-model> ;
[ set-model ] [ 2drop ] if ;
: <filter> ( model quot -- filter-model ) [ 1array filter-model <multi-model> ] dip >>quot ;
+! Behaviors - continuous model utilities
+
TUPLE: fold-model < multi-model oldval quot ;
M: fold-model model-changed [ [ value>> ] [ [ oldval>> ] [ quot>> ] bi ] bi*
call( val oldval -- newval ) ] keep set-model ;
-: <fold> ( oldval quot model -- model' ) 1array fold-model <multi-model> swap >>quot swap >>oldval ;
+: <fold> ( oldval quot model -- model' ) 1array fold-model <multi-model> swap >>quot
+ swap [ >>oldval ] [ >>value ] bi ;
-TUPLE: switch-model < multi-model switcher on ;
-M: switch-model model-changed tuck [ switcher>> = ] 2keep
- '[ on>> [ _ value>> _ set-model ] when ] [ t swap (>>on) ] if ;
-: switch ( signal1 signal2 -- signal' ) [ 2array switch-model <multi-model> ] keep >>switcher ;
+TUPLE: switch-model < multi-model original switcher on ;
+M: switch-model model-changed 2dup switcher>> =
+ [ over value>> [ [ value>> ] [ t >>on ] bi* set-model ] [ 2drop ] if ]
+ [ dup on>> [ 2drop ] [ [ value>> ] dip set-model ] if ] if ;
+M: switch-model model-activated [ original>> ] keep model-changed ;
+: <switch> ( signal1 signal2 -- signal' ) [ 2array switch-model <multi-model> ] 2keep
+ [ >>original ] [ >>switcher ] bi* ;
TUPLE: mapped < model model quot ;
INSTANCE: gadget monad
M: gadget monad-of drop gadget-monad ;
M: gadget-monad return drop <gadget> swap >>model ;
-M: gadget >>= model>> '[ _ swap call( x -- y ) ] ;
\ No newline at end of file
+M: gadget >>= output-model [ swap call( x -- y ) ] curry ;
\ No newline at end of file
+++ /dev/null
-! Copyright (C) 2008 Joe Groff.
-! See http://factorcode.org/license.txt for BSD license.
-USING: help.markup help.syntax kernel quotations ui.gadgets
-images strings ui.gadgets.worlds ;
-IN: ui.offscreen
-
-HELP: <offscreen-world>
-{ $values
- { "gadget" gadget } { "title" string } { "status" "a boolean" }
- { "world" offscreen-world }
-}
-{ $description "Constructs an " { $link offscreen-world } " gadget with " { $snippet "gadget" } " as its only child. Generally you should use " { $link open-offscreen } " or " { $link do-offscreen } " instead of calling this word directly." } ;
-
-HELP: close-offscreen
-{ $values
- { "world" offscreen-world }
-}
-{ $description "Releases the resources used by the rendering buffer for " { $snippet "world" } "." } ;
-
-HELP: do-offscreen
-{ $values
- { "gadget" gadget } { "quot" quotation }
-}
-{ $description "Constructs an " { $link offscreen-world } " around " { $snippet "gadget" } " with " { $link open-offscreen } ", calls " { $snippet "quotation" } " with the world on the top of the stack, and cleans up the world with " { $link close-offscreen } " at the end of " { $snippet "quotation" } "." } ;
-
-HELP: gadget>bitmap
-{ $values
- { "gadget" gadget }
- { "image" image }
-}
-{ $description "Renders " { $snippet "gadget" } " to an " { $link offscreen-world } " and creates an " { $link image } " from its contents." } ;
-
-HELP: offscreen-world
-{ $class-description "The class of " { $link world } " objects that render to an offscreen buffer." } ;
-
-HELP: offscreen-world>bitmap
-{ $values
- { "world" offscreen-world }
- { "image" image }
-}
-{ $description "Saves a copy of the contents of " { $snippet "world" } " to a " { $link image } " object." } ;
-
-HELP: open-offscreen
-{ $values
- { "gadget" gadget }
- { "world" offscreen-world }
-}
-{ $description "Creates and sets up an " { $link offscreen-world } " with " { $snippet "gadget" } " as its only child." } ;
-
-{ offscreen-world open-offscreen close-offscreen do-offscreen } related-words
-
-ARTICLE: "ui.offscreen" "Offscreen UI rendering"
-"The " { $vocab-link "ui.offscreen" } " provides words for rendering gadgets to an offscreen buffer so that bitmaps can be made from their contents."
-{ $subsection offscreen-world }
-"Opening gadgets offscreen:"
-{ $subsection open-offscreen }
-{ $subsection close-offscreen }
-{ $subsection do-offscreen }
-"Creating bitmaps from offscreen buffers:"
-{ $subsection offscreen-world>bitmap }
-{ $subsection gadget>bitmap } ;
-
-ABOUT: "ui.offscreen"
+++ /dev/null
-! (c) 2008 Joe Groff, see license for details
-USING: accessors alien.c-types continuations images kernel math
-sequences ui.gadgets ui.gadgets.private ui.gadgets.worlds
-ui.private ui ui.backend destructors locals ;
-IN: ui.offscreen
-
-TUPLE: offscreen-world < world ;
-
-: <offscreen-world> ( gadget title status -- world )
- offscreen-world new-world ;
-
-M: offscreen-world graft*
- (open-offscreen-buffer) ;
-
-M: offscreen-world ungraft*
- [ (ungraft-world) ]
- [ handle>> (close-offscreen-buffer) ]
- [ reset-world ] tri ;
-
-: open-offscreen ( gadget -- world )
- "" f <offscreen-world>
- [ open-world-window ] [ relayout-1 ] [ ] tri
- notify-queued ;
-
-: close-offscreen ( world -- )
- ungraft notify-queued ;
-
-:: bgrx>bitmap ( alien w h -- image )
- <image>
- { w h } >>dim
- alien w h * 4 * memory>byte-array >>bitmap
- BGRX >>component-order ;
-
-: offscreen-world>bitmap ( world -- image )
- offscreen-pixels bgrx>bitmap ;
-
-: do-offscreen ( gadget quot: ( offscreen-world -- ) -- )
- [ open-offscreen ] dip
- over [ slip ] [ close-offscreen ] [ ] cleanup ; inline
-
-: gadget>bitmap ( gadget -- image )
- [ offscreen-world>bitmap ] do-offscreen ;
+++ /dev/null
-Offscreen world gadgets for rendering UI elements to bitmaps
+++ /dev/null
-ui
-graphics
--- /dev/null
+! Copyright (C) 2008 Joe Groff.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax kernel quotations ui.gadgets
+images strings ui.gadgets.worlds ;
+IN: ui.offscreen
+
+HELP: <offscreen-world>
+{ $values
+ { "gadget" gadget } { "title" string } { "status" "a boolean" }
+ { "world" offscreen-world }
+}
+{ $description "Constructs an " { $link offscreen-world } " gadget with " { $snippet "gadget" } " as its only child. Generally you should use " { $link open-offscreen } " or " { $link do-offscreen } " instead of calling this word directly." } ;
+
+HELP: close-offscreen
+{ $values
+ { "world" offscreen-world }
+}
+{ $description "Releases the resources used by the rendering buffer for " { $snippet "world" } "." } ;
+
+HELP: do-offscreen
+{ $values
+ { "gadget" gadget } { "quot" quotation }
+}
+{ $description "Constructs an " { $link offscreen-world } " around " { $snippet "gadget" } " with " { $link open-offscreen } ", calls " { $snippet "quotation" } " with the world on the top of the stack, and cleans up the world with " { $link close-offscreen } " at the end of " { $snippet "quotation" } "." } ;
+
+HELP: gadget>bitmap
+{ $values
+ { "gadget" gadget }
+ { "image" image }
+}
+{ $description "Renders " { $snippet "gadget" } " to an " { $link offscreen-world } " and creates an " { $link image } " from its contents." } ;
+
+HELP: offscreen-world
+{ $class-description "The class of " { $link world } " objects that render to an offscreen buffer." } ;
+
+HELP: offscreen-world>bitmap
+{ $values
+ { "world" offscreen-world }
+ { "image" image }
+}
+{ $description "Saves a copy of the contents of " { $snippet "world" } " to a " { $link image } " object." } ;
+
+HELP: open-offscreen
+{ $values
+ { "gadget" gadget }
+ { "world" offscreen-world }
+}
+{ $description "Creates and sets up an " { $link offscreen-world } " with " { $snippet "gadget" } " as its only child." } ;
+
+{ offscreen-world open-offscreen close-offscreen do-offscreen } related-words
+
+ARTICLE: "ui.offscreen" "Offscreen UI rendering"
+"The " { $vocab-link "ui.offscreen" } " provides words for rendering gadgets to an offscreen buffer so that bitmaps can be made from their contents."
+{ $subsection offscreen-world }
+"Opening gadgets offscreen:"
+{ $subsection open-offscreen }
+{ $subsection close-offscreen }
+{ $subsection do-offscreen }
+"Creating bitmaps from offscreen buffers:"
+{ $subsection offscreen-world>bitmap }
+{ $subsection gadget>bitmap } ;
+
+ABOUT: "ui.offscreen"
--- /dev/null
+! (c) 2008 Joe Groff, see license for details
+USING: accessors alien.c-types continuations images kernel math
+sequences ui.gadgets ui.gadgets.private ui.gadgets.worlds
+ui.private ui ui.backend destructors locals ;
+IN: ui.offscreen
+
+TUPLE: offscreen-world < world ;
+
+M: offscreen-world world-pixel-format-attributes
+ { offscreen T{ depth-bits { value 16 } } } ;
+
+: <offscreen-world> ( gadget title status -- world )
+ offscreen-world new-world ;
+
+M: offscreen-world graft*
+ (open-offscreen-buffer) ;
+
+M: offscreen-world ungraft*
+ [ (ungraft-world) ]
+ [ handle>> (close-offscreen-buffer) ]
+ [ reset-world ] tri ;
+
+: open-offscreen ( gadget -- world )
+ "" f <offscreen-world>
+ [ open-world-window ] [ relayout-1 ] [ ] tri
+ notify-queued ;
+
+: close-offscreen ( world -- )
+ ungraft notify-queued ;
+
+:: bgrx>bitmap ( alien w h -- image )
+ <image>
+ { w h } >>dim
+ alien w h * 4 * memory>byte-array >>bitmap
+ BGRX >>component-order ;
+
+: offscreen-world>bitmap ( world -- image )
+ offscreen-pixels bgrx>bitmap ;
+
+: do-offscreen ( gadget quot: ( offscreen-world -- ) -- )
+ [ open-offscreen ] dip
+ over [ slip ] [ close-offscreen ] [ ] cleanup ; inline
+
+: gadget>bitmap ( gadget -- image )
+ [ offscreen-world>bitmap ] do-offscreen ;
--- /dev/null
+Offscreen world gadgets for rendering UI elements to bitmaps
--- /dev/null
+ui
+graphics
projects / factor.git / commitdiff