[ ]
} cleave ;
-: normalize-c-arg ( type name -- type' name' )
- [ length ]
- [
- [ CHAR: * = ] trim-head
- [ length - CHAR: * <array> append ] keep
- ] bi
- [ parse-c-type ] dip ;
-
<PRIVATE
GENERIC: return-type-name ( type -- name )
M: object return-type-name drop "void" ;
M: word return-type-name name>> ;
M: pointer return-type-name to>> return-type-name CHAR: * suffix ;
+
+: parse-pointers ( type name -- type' name' )
+ "*" ?head
+ [ [ <pointer> ] dip parse-pointers ] when ;
+
PRIVATE>
-: parse-arglist ( parameters return -- types effect )
- [
- 2 group [ first2 normalize-c-arg 2array ] map
- unzip [ "," ?tail drop ] map
- ]
- [ [ { } ] [ return-type-name 1array ] if-void ]
- bi* <effect> ;
+: scan-function-name ( -- return function )
+ scan-c-type scan parse-pointers ;
+
+:: (scan-c-args) ( end-marker types names -- )
+ scan :> type-str
+ type-str end-marker = [
+ type-str { "(" ")" } member? [
+ type-str parse-c-type :> type
+ scan "," ?tail drop :> name
+ type name parse-pointers :> ( type' name' )
+ type' types push name' names push
+ ] unless
+ end-marker types names (scan-c-args)
+ ] unless ;
+
+: scan-c-args ( end-marker -- types names )
+ V{ } clone V{ } clone [ (scan-c-args) ] 2keep [ >array ] bi@ ;
: function-quot ( return library function types -- quot )
'[ _ _ _ _ alien-invoke ] ;
-:: make-function ( return library function parameters -- word quot effect )
- return function normalize-c-arg :> ( return function )
- function create-in dup reset-generic
- return library function
- parameters return parse-arglist [ function-quot ] dip ;
+: function-effect ( names return -- effect )
+ [ { } ] [ return-type-name 1array ] if-void <effect> ;
-: parse-arg-tokens ( -- tokens )
- ";" parse-tokens [ "()" subseq? not ] filter ;
+:: make-function ( return function library types names -- word quot effect )
+ function create-in dup reset-generic
+ return library function types function-quot
+ names return function-effect ;
: (FUNCTION:) ( -- word quot effect )
- scan "c-library" get scan parse-arg-tokens make-function ;
-
-: define-function ( return library function parameters -- )
- make-function define-declared ;
+ scan-function-name "c-library" get ";" scan-c-args make-function ;
: callback-quot ( return types abi -- quot )
'[ [ _ _ _ ] dip alien-callback ] ;
-:: make-callback-type ( lib return type-name parameters -- word quot effect )
- return type-name normalize-c-arg :> ( return type-name )
+:: make-callback-type ( lib return type-name types names -- word quot effect )
type-name current-vocab create :> type-word
type-word [ reset-generic ] [ reset-c-type ] bi
void* type-word typedef
- parameters return parse-arglist :> ( types callback-effect )
- type-word callback-effect "callback-effect" set-word-prop
+ type-word names return function-effect "callback-effect" set-word-prop
type-word lib "callback-library" set-word-prop
type-word return types lib library-abi callback-quot (( quot -- alien )) ;
: (CALLBACK:) ( -- word quot effect )
"c-library" get
- scan scan parse-arg-tokens make-callback-type ;
+ scan-function-name ";" scan-c-args make-callback-type ;
PREDICATE: alien-function-word < word
def>> {
{ $values { "c-type" "a C type" } { "?" "a boolean" } }
{ $description "Tests if a C type is a structure defined by " { $link POSTPONE: STRUCT: } "." } ;
-HELP: define-function
-{ $values { "return" "a C return type" } { "library" "a logical library name" } { "function" "a C function name" } { "parameters" "a sequence of C parameter types" } }
-{ $description "Defines a word named " { $snippet "function" } " in the current vocabulary (see " { $link "vocabularies" } "). The word calls " { $link alien-invoke } " with the specified parameters." }
-{ $notes "This word is used to implement the " { $link POSTPONE: FUNCTION: } " parsing word." } ;
-
HELP: C-GLOBAL:
{ $syntax "C-GLOBAL: type name" }
{ $values { "type" "a C type" } { "name" "a C global variable name" } }
: microseconds ( x -- duration ) 1000000 / seconds ;
: nanoseconds ( x -- duration ) 1000000000 / seconds ;
-GENERIC: year ( obj -- n )
-M: integer year ;
-M: timestamp year year>> ;
-
-GENERIC: month ( obj -- n )
-M: integer month ;
-M: timestamp month month>> ;
-
-GENERIC: day ( obj -- n )
-M: integer day ;
-M: timestamp day day>> ;
-
GENERIC: leap-year? ( obj -- ? )
M: integer leap-year? ( year -- ? )
! Copyright (C) 2008, 2010 Slava Pestov, Doug Coleman.\r
! See http://factorcode.org/license.txt for BSD license.\r
-USING: math math.order math.parser math.functions kernel\r
-sequences io accessors arrays io.streams.string splitting\r
-combinators calendar calendar.format.macros present ;\r
+USING: accessors arrays calendar calendar.format.macros\r
+combinators io io.streams.string kernel math math.functions\r
+math.order math.parser present sequences typed ;\r
IN: calendar.format\r
\r
: pad-00 ( n -- str ) number>string 2 CHAR: 0 pad-head ;\r
: (timestamp>ymd) ( timestamp -- )\r
{ YYYY "-" MM "-" DD } formatted ;\r
\r
-: timestamp>ymd ( timestamp -- str )\r
+TYPED: timestamp>ymd ( timestamp: timestamp -- str )\r
[ (timestamp>ymd) ] with-string-writer ;\r
\r
: (timestamp>hms) ( timestamp -- )\r
{ hh ":" mm ":" ss } formatted ;\r
\r
-: timestamp>hms ( timestamp -- str )\r
+TYPED: timestamp>hms ( timestamp: timestamp -- str )\r
[ (timestamp>hms) ] with-string-writer ;\r
\r
-: timestamp>ymdhms ( timestamp -- str )\r
+TYPED: timestamp>ymdhms ( timestamp: timestamp -- str )\r
[\r
>gmt\r
{ (timestamp>ymd) " " (timestamp>hms) } formatted\r
<PRIVATE
-: ((reset-timer)) ( timer counter timestamp -- )
- nip >CFAbsoluteTime CFRunLoopTimerSetNextFireDate ;
+: (reset-timer) ( timer timestamp -- )
+ >CFAbsoluteTime CFRunLoopTimerSetNextFireDate ;
-: nano-count>timestamp ( x -- timestamp )
- nano-count - nanoseconds now time+ ;
+: nano-count>micros ( x -- n )
+ nano-count - 1,000 /f system-micros + ;
-: (reset-timer) ( timer counter -- )
+: reset-timer ( timer -- )
yield {
- { [ dup 0 = ] [ now ((reset-timer)) ] }
- { [ run-queue deque-empty? not ] [ 1 - (reset-timer) ] }
- { [ sleep-queue heap-empty? ] [ 5 minutes hence ((reset-timer)) ] }
- [ sleep-queue heap-peek nip nano-count>timestamp ((reset-timer)) ]
+ { [ run-queue deque-empty? not ] [ yield system-micros (reset-timer) ] }
+ { [ sleep-queue heap-empty? ] [ system-micros 1,000,000 + (reset-timer) ] }
+ [ sleep-queue heap-peek nip nano-count>micros (reset-timer) ]
} cond ;
-: reset-timer ( timer -- )
- 10 (reset-timer) ;
-
PRIVATE>
: reset-run-loop ( -- )
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: calendar alien.c-types alien.syntax ;
+USING: calendar math alien.c-types alien.syntax memoize system ;
IN: core-foundation.time
TYPEDEF: double CFTimeInterval
: >CFTimeInterval ( duration -- interval )
duration>seconds ; inline
-: >CFAbsoluteTime ( timestamp -- time )
- T{ timestamp { year 2001 } { month 1 } { day 1 } } time-
- duration>seconds ; inline
+MEMO: epoch ( -- micros )
+ T{ timestamp { year 2001 } { month 1 } { day 1 } } timestamp>micros ;
+
+: >CFAbsoluteTime ( micros -- time )
+ epoch - 1,000,000 /f ; inline
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.c-types alien.syntax system math kernel calendar
core-foundation core-foundation.time ;
) ;
: <CFTimer> ( callback -- timer )
- [ f now >CFAbsoluteTime 60 0 0 ] dip f CFRunLoopTimerCreate ;
+ [ f system-micros >CFAbsoluteTime 60 0 0 ] dip f CFRunLoopTimerCreate ;
FUNCTION: void CFRunLoopTimerInvalidate (
CFRunLoopTimerRef timer
USING: help.syntax help.markup kernel prettyprint sequences
-io.pathnames ;
+io.pathnames strings ;
IN: csv
HELP: csv
}
{ $description "Writes a comma-separated-value structure to a file." } ;
+HELP: string>csv
+{ $values
+ { "string" string }
+ { "csv" "csv" }
+}
+{ $description "Parses a string into a sequence of comma-separated-value fields." } ;
+
+HELP: csv>string
+{ $values
+ { "csv" "csv" }
+ { "string" string }
+}
+{ $description "Writes a comma-separated-value structure to a string." } ;
+
HELP: csv-row
{ $values { "stream" "an input stream" }
{ "row" "an array of fields" } }
{ $subsections file>csv }
"Writing a csv file:"
{ $subsections csv>file }
+"Reading a string to csv:"
+{ $subsections string>csv }
+"Writing csv to a string:"
+{ $subsections csv>string }
"Changing the delimiter from a comma:"
{ $subsections with-delimiter }
"Reading from a stream:"
! Copyright (C) 2007, 2008 Phil Dawes
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences io namespaces make combinators
-unicode.categories io.files combinators.short-circuit ;
+unicode.categories io.files combinators.short-circuit
+io.streams.string ;
IN: csv
SYMBOL: delimiter
[ [ (csv) ] { } make ] with-input-stream
dup last { "" } = [ but-last ] when ;
+: string>csv ( string -- csv )
+ <string-reader> csv ;
+
: file>csv ( path encoding -- csv )
<file-reader> csv ;
: write-row ( row -- )
[ delimiter get write1 ]
[ escape-if-required write ] interleave nl ; inline
+
+<PRIVATE
+
+: (write-csv) ( rows -- )
+ [ write-row ] each ;
+PRIVATE>
+
: write-csv ( rows stream -- )
- [ [ write-row ] each ] with-output-stream ;
+ [ (write-csv) ] with-output-stream ;
+: csv>string ( csv -- string )
+ [ (write-csv) ] with-string-writer ;
+
: csv>file ( rows path encoding -- ) <file-writer> write-csv ;
M: protocol group-words protocol-words ;
SYNTAX: SLOT-PROTOCOL:
- CREATE-WORD ";" parse-tokens
- [ [ reader-word ] [ writer-word ] bi 2array ] map concat
- define-protocol ;
\ No newline at end of file
+ CREATE-WORD ";"
+ [ [ reader-word ] [ writer-word ] bi 2array ]
+ map-tokens concat define-protocol ;
{
{ [ os windows? ] [ "game.input.xinput" require ] }
{ [ os macosx? ] [ "game.input.iokit" require ] }
- { [ os linux? ] [ "game.input.linux" require ] }
+ { [ os linux? ] [ "game.input.x11" require ] }
[ ]
} cond
+++ /dev/null
-Erik Charlebois
\ No newline at end of file
+++ /dev/null
-! Copyright (C) 2010 Erik Charlebois.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel game.input namespaces classes bit-arrays vectors ;
-IN: game.input.linux
-
-SINGLETON: linux-game-input-backend
-
-linux-game-input-backend game-input-backend set-global
-
-M: linux-game-input-backend (open-game-input)
- ;
-
-M: linux-game-input-backend (close-game-input)
- ;
-
-M: linux-game-input-backend (reset-game-input)
- ;
-
-M: linux-game-input-backend get-controllers
- { } ;
-
-M: linux-game-input-backend product-string
- drop "" ;
-
-M: linux-game-input-backend product-id
- drop f ;
-
-M: linux-game-input-backend instance-id
- drop f ;
-
-M: linux-game-input-backend read-controller
- drop controller-state new ;
-
-M: linux-game-input-backend calibrate-controller
- drop ;
-
-M: linux-game-input-backend vibrate-controller
- 3drop ;
-
-M: linux-game-input-backend read-keyboard
- 256 <bit-array> keyboard-state boa ;
-
-M: linux-game-input-backend read-mouse
- 0 0 0 0 2 <vector> mouse-state boa ;
-
-M: linux-game-input-backend reset-mouse
- ;
+++ /dev/null
-Linux backend for game input.
--- /dev/null
+Erik Charlebois
+William Schlieper
--- /dev/null
+Linux backend for game input.
--- /dev/null
+! Copyright (C) 2010 Erik Charlebois, William Schlieper.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays kernel game.input namespaces
+classes bit-arrays system sequences vectors x11 x11.xlib ;
+IN: game.input.x11
+
+SINGLETON: x11-game-input-backend
+
+x11-game-input-backend game-input-backend set-global
+
+M: x11-game-input-backend (open-game-input)
+ ;
+
+M: x11-game-input-backend (close-game-input)
+ ;
+
+M: x11-game-input-backend (reset-game-input)
+ ;
+
+M: x11-game-input-backend get-controllers
+ { } ;
+
+M: x11-game-input-backend product-string
+ drop "" ;
+
+M: x11-game-input-backend product-id
+ drop f ;
+
+M: x11-game-input-backend instance-id
+ drop f ;
+
+M: x11-game-input-backend read-controller
+ drop controller-state new ;
+
+M: x11-game-input-backend calibrate-controller
+ drop ;
+
+M: x11-game-input-backend vibrate-controller
+ 3drop ;
+
+HOOK: x>hid-bit-order os ( -- x )
+
+M: linux x>hid-bit-order
+ {
+ 0 0 0 0 0 0 0 0
+ 0 41 30 31 32 33 34 35
+ 36 37 38 39 45 46 42 43
+ 20 26 8 21 23 28 24 12
+ 18 19 47 48 40 224 4 22
+ 7 9 10 11 13 14 15 51
+ 52 53 225 49 29 27 6 25
+ 5 17 16 54 55 56 229 85
+ 226 44 57 58 59 60 61 62
+ 63 64 65 66 67 83 71 95
+ 96 97 86 92 93 94 87 91
+ 90 89 98 99 0 0 0 68
+ 69 0 0 0 0 0 0 0
+ 88 228 84 70 0 0 74 82
+ 75 80 79 77 81 78 73 76
+ 127 129 128 102 103 0 72 0
+ 0 0 0 227 231 0 0 0
+ 0 0 0 0 0 0 0 0
+ 0 0 0 0 0 0 0 0
+ 0 0 0 0 0 0 0 0
+ 0 0 0 0 0 0 0 0
+ 0 0 0 0 0 0 0 0
+ 0 0 0 0 0 0 0 0
+ 0 0 0 0 0 0 0 0
+ 0 0 0 0 0 0 0 0
+ 0 0 0 0 0 0 0 0
+ 0 0 0 0 0 0 0 0
+ 0 0 0 0 0 0 0 0
+ 0 0 0 0 0 0 0 0
+ 0 0 0 0 0 0 0 0
+ 0 0 0 0 0 0 0 0
+ 0 0 0 0 0 0 0 0
+ } ; inline
+
+: x-bits>hid-bits ( bit-array -- bit-array )
+ 256 iota [ 2array ] { } 2map-as [ first ] filter [ second ] map
+ x>hid-bit-order [ nth ] curry map
+ 256 <bit-array> swap [ t swap pick set-nth ] each ;
+
+M: x11-game-input-backend read-keyboard
+ dpy get 256 <bit-array> [ XQueryKeymap drop ] keep
+ x-bits>hid-bits keyboard-state boa ;
+
+M: x11-game-input-backend read-mouse
+ 0 0 0 0 2 <vector> mouse-state boa ;
+
+M: x11-game-input-backend reset-mouse
+ ;
! Copyright (C) 2005, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math math.order strings arrays vectors sequences
-sequences.private accessors fry combinators.short-circuit ;
+sequences.private accessors fry combinators.short-circuit
+combinators ;
IN: grouping
<PRIVATE
: all-eq? ( seq -- ? ) [ eq? ] monotonic? ;
-TUPLE: circular-slice < slice ;
+TUPLE: circular-slice
+ { from read-only }
+ { to read-only }
+ { seq read-only } ;
+INSTANCE: circular-slice virtual-sequence
+M: circular-slice equal? over slice? [ sequence= ] [ 2drop f ] if ;
+M: circular-slice hashcode* [ sequence-hashcode ] recursive-hashcode ;
+M: circular-slice length [ to>> ] [ from>> ] bi - ; inline
+M: circular-slice virtual-exemplar seq>> ; inline
M: circular-slice virtual@
[ from>> + ] [ seq>> ] bi [ length slice-mod ] keep ; inline
: make-locals ( seq -- words assoc )
[ [ make-local ] map ] H{ } make-assoc ;
+: parse-local-defs ( -- words assoc )
+ [ "|" [ make-local ] map-tokens ] H{ } make-assoc ;
+
: make-local-word ( name def -- word )
[ <local-word> [ dup name>> set ] [ ] [ ] tri ] dip
"local-word-def" set-word-prop ;
[ \ ] parse-until >quotation ] ((parse-lambda)) ;
: parse-lambda ( -- lambda )
- "|" parse-tokens make-locals
+ parse-local-defs
(parse-lambda) <lambda>
?rewrite-closures ;
: parse-multi-def ( locals -- multi-def )
- ")" parse-tokens swap [ [ make-local ] map ] bind <multi-def> ;
+ [ ")" [ make-local ] map-tokens ] bind <multi-def> ;
: parse-def ( name/paren locals -- def )
over "(" = [ nip parse-multi-def ] [ [ make-local ] bind <def> ] if ;
[ define-match-var ] each ;
SYNTAX: MATCH-VARS: ! vars ...
- ";" parse-tokens define-match-vars ;
+ ";" [ define-match-var ] each-token ;
: match-var? ( symbol -- bool )
dup word? [ "match-var" word-prop ] [ drop f ] if ;
[ unknown-gl-platform ]
} cond use-vocab >>
-SYMBOL: +gl-function-number-counter+
+SYMBOL: +gl-function-counter+
SYMBOL: +gl-function-pointers+
: reset-gl-function-number-counter ( -- )
- 0 +gl-function-number-counter+ set-global ;
+ 0 +gl-function-counter+ set-global ;
: reset-gl-function-pointers ( -- )
100 <hashtable> +gl-function-pointers+ set-global ;
reset-gl-function-pointers
reset-gl-function-number-counter
-: gl-function-number ( -- n )
- +gl-function-number-counter+ get-global
- dup 1 + +gl-function-number-counter+ set-global ;
+: gl-function-counter ( -- n )
+ +gl-function-counter+ get-global
+ dup 1 + +gl-function-counter+ set-global ;
: gl-function-pointer ( names n -- funptr )
gl-function-context 2array dup +gl-function-pointers+ get-global at
: indirect-quot ( function-ptr-quot return types abi -- quot )
'[ @ _ _ _ alien-indirect ] ;
-:: define-indirect ( abi return function-ptr-quot function-name parameters -- )
+:: define-indirect ( abi return function-name function-ptr-quot types names -- )
function-name create-in dup reset-generic
- function-ptr-quot return
- parameters return parse-arglist [ abi indirect-quot ] dip
+ function-ptr-quot return types abi indirect-quot
+ names return function-effect
define-declared ;
SYNTAX: GL-FUNCTION:
gl-function-calling-convention
- scan-c-type
- scan dup
- scan drop "}" parse-tokens swap prefix
- gl-function-number
- [ gl-function-pointer ] 2curry swap
- ";" parse-tokens [ "()" subseq? not ] filter
- define-indirect ;
+ scan-function-name
+ "{" expect "}" parse-tokens over prefix
+ gl-function-counter '[ _ _ gl-function-pointer ]
+ ";" scan-c-args define-indirect ;
M: pointer c-direct-array-constructor drop void* c-direct-array-constructor ;
SYNTAX: SPECIALIZED-ARRAYS:
- ";" parse-tokens [ parse-c-type define-array-vocab use-vocab ] each ;
+ ";" [ parse-c-type define-array-vocab use-vocab ] each-token ;
SYNTAX: SPECIALIZED-ARRAY:
scan-c-type define-array-vocab use-vocab ;
generate-vocab ;
SYNTAX: SPECIALIZED-VECTORS:
- ";" parse-tokens [
+ ";" [
parse-c-type
[ define-array-vocab use-vocab ]
[ define-vector-vocab use-vocab ] bi
- ] each ;
+ ] each-token ;
SYNTAX: SPECIALIZED-VECTOR:
scan-c-type
}
TUPLE: world < track
- active? focused? grab-input?
+ active? focused? grab-input? fullscreen?
+ saved-position
layers
title status status-owner
text-handle handle images
effects kernel windows.ole32 parser lexer splitting grouping
sequences namespaces assocs quotations generalizations
accessors words macros alien.syntax fry arrays layouts math
-classes.struct windows.kernel32 ;
-FROM: alien.parser.private => return-type-name ;
+classes.struct windows.kernel32 locals ;
+FROM: alien.parser.private => parse-pointers return-type-name ;
IN: windows.com.syntax
<PRIVATE
TUPLE: com-interface-definition word parent iid functions ;
C: <com-interface-definition> com-interface-definition
-TUPLE: com-function-definition name return parameters ;
+TUPLE: com-function-definition return name parameter-types parameter-names ;
C: <com-function-definition> com-function-definition
SYMBOL: +com-interface-definitions+
: save-com-interface-definition ( definition -- )
dup word>> +com-interface-definitions+ get-global set-at ;
-: (parse-com-function) ( tokens -- definition )
- [ second ]
- [ first parse-c-type ]
- [
- 3 tail [ CHAR: , swap remove ] map
- 2 group [ first2 normalize-c-arg 2array ] map
- { void* "this" } prefix
- ] tri
+: (parse-com-function) ( return name -- definition )
+ ")" scan-c-args
+ [ pointer: void prefix ] [ "this" prefix ] bi*
<com-function-definition> ;
+:: (parse-com-functions) ( functions -- )
+ scan dup ";" = [ drop ] [
+ parse-c-type scan parse-pointers
+ (parse-com-function) functions push
+ functions (parse-com-functions)
+ ] if ;
+
: parse-com-functions ( -- functions )
- ";" parse-tokens { ")" } split harvest
- [ (parse-com-function) ] map ;
+ V{ } clone [ (parse-com-functions) ] keep >array ;
: (iid-word) ( definition -- word )
word>> name>> "-iid" append create-in ;
dup parent>> [ family-tree-functions ] [ { } ] if*
swap functions>> append ;
-: (invocation-quot) ( function return parameters -- quot )
- [ first ] map [ com-invoke ] 3curry ;
-
-: (stack-effect-from-return-and-parameters) ( return parameters -- stack-effect )
- swap
- [ [ second ] map ]
- [ dup void? [ drop { } ] [ return-type-name 1array ] if ] bi*
- <effect> ;
-
-: (define-word-for-function) ( function interface n -- )
- -rot [ (function-word) swap ] 2keep drop
- [ return>> ] [ parameters>> ] bi
- [ (invocation-quot) ] 2keep
- (stack-effect-from-return-and-parameters)
+:: (define-word-for-function) ( function interface n -- )
+ function interface (function-word)
+ n function [ return>> ] [ parameter-types>> ] bi '[ _ _ _ com-invoke ]
+ function [ parameter-names>> ] [ return>> ] bi function-effect
define-declared ;
: define-words-for-com-interface ( definition -- )
keep (next-vtbl-counter) '[
swap [
[ name>> _ _ (callback-word) ]
- [ return>> ] [
- parameters>>
- [ [ first ] map ]
- [ length ] bi
- ] tri
+ [ return>> ] [ parameter-types>> dup length ] tri
] [
first2 (finish-thunk)
] bi*
HRESULT Clear ( DWORD Count, D3DRECT* pRects, DWORD Flags, D3DCOLOR Color, float Z, DWORD Stencil )
HRESULT SetTransform ( D3DTRANSFORMSTATETYPE State, D3DMATRIX* pMatrix )
HRESULT GetTransform ( D3DTRANSFORMSTATETYPE State, D3DMATRIX* pMatrix )
- HRESULT MultiplyTransform ( D3DTRANSFORMSTATETYPE, D3DMATRIX* )
+ HRESULT MultiplyTransform ( D3DTRANSFORMSTATETYPE State, D3DMATRIX* pMatrix )
HRESULT SetViewport ( D3DVIEWPORT9* pViewport )
HRESULT GetViewport ( D3DVIEWPORT9* pViewport )
HRESULT SetMaterial ( D3DMATERIAL9* pMaterial )
CONSTANT: SWP_NOCOPYBITS 256
CONSTANT: SWP_NOOWNERZORDER 512
CONSTANT: SWP_NOSENDCHANGING 1024
-CONSTANT: SWP_DRAWFRAME SWP_FRAMECHANGED
-CONSTANT: SWP_NOREPOSITION SWP_NOOWNERZORDER
+ALIAS: SWP_DRAWFRAME SWP_FRAMECHANGED
+ALIAS: SWP_NOREPOSITION SWP_NOOWNERZORDER
CONSTANT: SWP_DEFERERASE 8192
CONSTANT: SWP_ASYNCWINDOWPOS 16384
! FUNCTION: EnumDesktopWindows
! FUNCTION: EnumDisplayDevicesA
! FUNCTION: EnumDisplayDevicesW
-! FUNCTION: EnumDisplayMonitors
+! FUNCTION: BOOL EnumDisplayMonitors ( HDC hdc, LPCRECT lprcClip, MONITORENUMPROC lpfnEnum, LPARAM dwData ) ;
! FUNCTION: EnumDisplaySettingsA
! FUNCTION: EnumDisplaySettingsExA
! FUNCTION: EnumDisplaySettingsExW
! FUNCTION: GetDlgItemTextW
FUNCTION: uint GetDoubleClickTime ( ) ;
FUNCTION: HWND GetFocus ( ) ;
-! FUNCTION: GetForegroundWindow
+FUNCTION: HWND GetForegroundWindow ( ) ;
! FUNCTION: GetGuiResources
! FUNCTION: GetGUIThreadInfo
! FUNCTION: GetIconInfo
FUNCTION: LONG_PTR GetWindowLongW ( HANDLE hWnd, int index ) ;
ALIAS: GetWindowLong GetWindowLongW
-FUNCTION: LONG_PTR GetWindowLongPtr ( HWND hWnd, int nIndex ) ;
+FUNCTION: LONG_PTR GetWindowLongPtrW ( HWND hWnd, int nIndex ) ;
+ALIAS: GetWindowLongPtr GetWindowLongPtrW
! FUNCTION: GetWindowModuleFileName
! FUNCTION: GetWindowModuleFileNameA
! FUNCTION: GetWindowModuleFileNameW
! FUNCTION: SetWindowPlacement
FUNCTION: BOOL SetWindowPos ( HWND hWnd, HWND hWndInsertAfter, int X, int Y, int cx, int cy, UINT uFlags ) ;
-FUNCTION: LONG_PTR SetWindowLongPtr ( HWND hWnd, int nIndex, LONG_PTR dwNewLong ) ;
+FUNCTION: LONG_PTR SetWindowLongPtrW ( HWND hWnd, int nIndex, LONG_PTR dwNewLong ) ;
+ALIAS: SetWindowLongPtr SetWindowLongPtrW
: HWND_BOTTOM ( -- alien ) 1 <alien> ;
: HWND_NOTOPMOST ( -- alien ) -2 <alien> ;
X-FUNCTION: Bool XSupportsLocale ( ) ;
X-FUNCTION: c-string XSetLocaleModifiers ( c-string modifier_list ) ;
+
+! uncategorized xlib bindings
+
+X-FUNCTION: int XQueryKeymap ( Display* display, char[32] keys_return ) ;
+
M: sequence string>symbol [ string>symbol* ] map ;
[
- 8 special-object utf8 alien>string string>cpu \ cpu set-global
- 9 special-object utf8 alien>string string>os \ os set-global
+ 8 special-object utf8 alien>string string>cpu \ cpu set-global
+ 9 special-object utf8 alien>string string>os \ os set-global
+ 67 special-object utf8 alien>string \ vm-compiler set-global
] "alien.strings" add-startup-hook
ERROR: bad-literal-tuple ;
-: parse-slot-value ( -- )
- scan scan-object 2array , scan {
+ERROR: bad-slot-name class slot ;
+
+: check-slot-name ( class slots name -- name )
+ 2dup swap slot-named* nip [ 2nip ] [ nip bad-slot-name ] if ;
+
+: parse-slot-value ( class slots -- )
+ scan check-slot-name scan-object 2array , scan {
{ f [ \ } unexpected-eof ] }
{ "}" [ ] }
[ bad-literal-tuple ]
} case ;
-: (parse-slot-values) ( -- )
- parse-slot-value
+: (parse-slot-values) ( class slots -- )
+ 2dup parse-slot-value
scan {
- { f [ \ } unexpected-eof ] }
+ { f [ 2drop \ } unexpected-eof ] }
{ "{" [ (parse-slot-values) ] }
- { "}" [ ] }
- [ bad-literal-tuple ]
+ { "}" [ 2drop ] }
+ [ 2nip bad-literal-tuple ]
} case ;
-: parse-slot-values ( -- values )
+: parse-slot-values ( class slots -- values )
[ (parse-slot-values) ] { } make ;
GENERIC# boa>object 1 ( class slots -- tuple )
M: tuple-class boa>object
swap prefix >tuple ;
-ERROR: bad-slot-name class slot ;
-
: check-slot-exists ( class initials slot-spec/f index/f name -- class initials slot-spec index )
over [ drop ] [ nip nip nip bad-slot-name ] if ;
scan {
{ f [ unexpected-eof ] }
{ "f" [ drop \ } parse-until boa>object ] }
- { "{" [ parse-slot-values assoc>object ] }
+ { "{" [ 2dup parse-slot-values assoc>object ] }
{ "}" [ drop new ] }
[ bad-literal-tuple ]
} case ;
{ $values { "lexer" lexer } { "?" "a boolean" } }
{ $description "Outputs " { $link f } " if end of input has been reached, " { $link t } " otherwise." } ;
+HELP: each-token
+{ $values { "end" string } { "quot" { $quotation "( token -- )" } } }
+{ $description "Reads a sequence of tokens until the first occurrence of " { $snippet "end" } ". " { $snippet "quot" } " is called on each token as it is read." }
+{ $examples "This word is used to implement " { $link POSTPONE: USING: } "." }
+$parsing-note ;
+
+HELP: map-tokens
+{ $values { "end" string } { "quot" { $quotation "( token -- object )" } } { "seq" "a new sequence of " { $snippet "object" } "s" } }
+{ $description "Reads a sequence of tokens until the first occurrence of " { $snippet "end" } ". " { $snippet "quot" } " is called on each token as it is read, and the results are collected into a new output sequence." }
+$parsing-note ;
+
HELP: parse-tokens
{ $values { "end" string } { "seq" "a new sequence of strings" } }
-{ $description "Reads a sequence of tokens until the first occurrence of " { $snippet "end" } ". The tokens remain as strings and are not processed in any way." }
-{ $examples "This word is used to implement " { $link POSTPONE: USING: } "." }
+{ $description "Reads a sequence of tokens until the first occurrence of " { $snippet "end" } ". The tokens remain as strings and are not processed in any way. This word is equivalent to " { $link map-tokens } " with an empty quotation." }
$parsing-note ;
HELP: unexpected
[ unexpected-eof ]
if* ;
-: (parse-tokens) ( accum end -- accum )
- scan 2dup = [
- 2drop
- ] [
- [ pick push (parse-tokens) ] [ unexpected-eof ] if*
- ] if ;
+: (each-token) ( end quot -- pred quot )
+ [ [ [ scan dup ] ] dip [ = not ] curry [ [ f ] if* ] curry compose ] dip ; inline
+
+: each-token ( end quot -- )
+ (each-token) while drop ; inline
+
+: map-tokens ( end quot -- seq )
+ (each-token) produce nip ; inline
: parse-tokens ( end -- seq )
- 100 <vector> swap (parse-tokens) >array ;
+ [ ] map-tokens ;
TUPLE: lexer-error line column line-text error ;
$nl
"One example is the " { $link POSTPONE: USING: } " parsing word."
{ $see POSTPONE: USING: }
-"It reads a list of vocabularies terminated by " { $link POSTPONE: ; } ". However, the vocabulary names do not name words, except by coincidence; so " { $link parse-until } " cannot be used here. Instead, a lower-level word is called:"
-{ $subsections parse-tokens } ;
+"It reads a list of vocabularies terminated by " { $link POSTPONE: ; } ". However, the vocabulary names do not name words, except by coincidence; so " { $link parse-until } " cannot be used here. Instead, a set of lower-level combinators can be used:"
+{ $subsections
+ each-token
+ map-tokens
+ parse-tokens
+} ;
ARTICLE: "parsing-words" "Parsing words"
"The Factor parser follows a simple recursive-descent design. The parser reads successive tokens from the input; if the token identifies a number or an ordinary word, it is added to an accumulator vector. Otherwise if the token identifies a parsing word, the parsing word is executed immediately."
{ $examples "This word is used to implement " { $link POSTPONE: ARTICLE: } "." }
$parsing-note ;
-{ parse-tokens (parse-until) parse-until } related-words
+{ parse-tokens each-token map-tokens (parse-until) parse-until } related-words
HELP: (parse-lines)
{ $values { "lexer" lexer } { "quot" "a new " { $link quotation } } }
"UNUSE:" [ scan unuse-vocab ] define-core-syntax
- "USING:" [ ";" parse-tokens [ use-vocab ] each ] define-core-syntax
+ "USING:" [ ";" [ use-vocab ] each-token ] define-core-syntax
"QUALIFIED:" [ scan dup add-qualified ] define-core-syntax
] define-core-syntax
"SYMBOLS:" [
- ";" parse-tokens
- [ create-in dup reset-generic define-symbol ] each
+ ";" [ create-in dup reset-generic define-symbol ] each-token
] define-core-syntax
"SINGLETONS:" [
- ";" parse-tokens
- [ create-class-in define-singleton-class ] each
+ ";" [ create-class-in define-singleton-class ] each-token
] define-core-syntax
"DEFER:" [
: os ( -- class ) \ os get-global ; foldable
+: vm-compiler ( -- string ) \ vm-compiler get-global ; foldable
+
<PRIVATE
: string>cpu ( str -- class )
HOLIDAY: martin-luther-king-day january 3 monday-of-month ;
HOLIDAY-NAME: martin-luther-king-day us-federal "Martin Luther King Day"
-HOLIDAY: inauguration-day year dup 4 neg rem + january 20 >>day ;
+HOLIDAY: inauguration-day january 20 >>day [ dup 4 neg rem + ] change-year ;
HOLIDAY-NAME: inauguration-day us "Inauguration Day"
HOLIDAY: washingtons-birthday february 3 monday-of-month ;
--- /dev/null
+Doug Coleman
--- /dev/null
+! Copyright (C) 2010 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien.c-types arrays classes.struct fry kernel
+literals locals make math math.bitwise multiline sequences
+slots.syntax ui.backend.windows vocabs.loader windows.errors
+windows.gdi32 windows.kernel32 windows.types windows.user32
+ui.gadgets.worlds ;
+IN: fullscreen
+
+: hwnd>hmonitor ( HWND -- HMONITOR )
+ MONITOR_DEFAULTTOPRIMARY MonitorFromWindow ;
+
+: desktop-hmonitor ( -- HMONITOR )
+ GetDesktopWindow hwnd>hmonitor ;
+
+:: (monitor-info>devmodes) ( monitor-info n -- )
+ DEVMODE <struct>
+ DEVMODE heap-size >>dmSize
+ { DM_BITSPERPEL DM_PELSWIDTH DM_PELSHEIGHT } flags >>dmFields
+ :> devmode
+
+ monitor-info szDevice>>
+ n
+ devmode
+ EnumDisplaySettings 0 = [
+ devmode ,
+ monitor-info n 1 + (monitor-info>devmodes)
+ ] unless ;
+
+: monitor-info>devmodes ( monito-info -- devmodes )
+ [ 0 (monitor-info>devmodes) ] { } make ;
+
+: hmonitor>monitor-info ( HMONITOR -- monitor-info )
+ MONITORINFOEX <struct>
+ MONITORINFOEX heap-size >>cbSize
+ [ GetMonitorInfo win32-error=0/f ] keep ;
+
+: hwnd>monitor-info ( HWND -- monitor-info )
+ hwnd>hmonitor hmonitor>monitor-info ;
+
+: hmonitor>devmodes ( HMONITOR -- devmodes )
+ hmonitor>monitor-info monitor-info>devmodes ;
+
+: desktop-devmodes ( -- DEVMODEs )
+ desktop-hmonitor hmonitor>devmodes ;
+
+: desktop-monitor-info ( -- monitor-info )
+ desktop-hmonitor hmonitor>monitor-info ;
+
+: desktop-RECT ( -- RECT )
+ GetDesktopWindow RECT <struct> [ GetWindowRect win32-error=0/f ] keep ;
+
+ERROR: display-change-error n ;
+
+: fullscreen-mode ( monitor-info devmode -- )
+ [ szDevice>> ] dip f CDS_FULLSCREEN f
+ ChangeDisplaySettingsEx dup DISP_CHANGE_SUCCESSFUL =
+ [ drop ] [ display-change-error ] if ;
+
+: non-fullscreen-mode ( monitor-info devmode -- )
+ [ szDevice>> ] dip f 0 f
+ ChangeDisplaySettingsEx dup DISP_CHANGE_SUCCESSFUL =
+ [ drop ] [ display-change-error ] if ;
+
+: get-style ( hwnd n -- style )
+ GetWindowLongPtr [ win32-error=0/f ] keep ;
+
+: set-style ( hwnd n style -- )
+ SetWindowLongPtr win32-error=0/f ;
+
+: change-style ( hwnd n quot -- )
+ [ 2dup get-style ] dip call set-style ; inline
+
+: set-fullscreen-styles ( hwnd -- )
+ [ GWL_STYLE [ WS_OVERLAPPEDWINDOW unmask ] change-style ]
+ [ GWL_EXSTYLE [ { WS_EX_APPWINDOW WS_EX_TOPMOST } flags bitor ] change-style ] bi ;
+
+: set-non-fullscreen-styles ( hwnd -- )
+ [ GWL_STYLE [ WS_OVERLAPPEDWINDOW bitor ] change-style ]
+ [ GWL_EXSTYLE [ { WS_EX_APPWINDOW WS_EX_TOPMOST } flags unmask ] change-style ] bi ;
+
+ERROR: unsupported-resolution triple ;
+
+:: find-devmode ( triple hwnd -- devmode )
+ hwnd hwnd>hmonitor hmonitor>devmodes
+ [
+ slots{ dmPelsWidth dmPelsHeight dmBitsPerPel }
+ triple =
+ ] find nip [ triple unsupported-resolution ] unless* ;
+
+:: set-fullscreen-window-position ( hwnd triple -- )
+ hwnd f
+ desktop-monitor-info rcMonitor>> slots{ left top } first2
+ triple first2
+ {
+ SWP_NOACTIVATE SWP_NOCOPYBITS SWP_NOOWNERZORDER
+ SWP_NOREPOSITION SWP_NOZORDER
+ } flags
+ SetWindowPos win32-error=0/f ;
+
+:: enable-fullscreen ( triple hwnd -- rect )
+ hwnd hwnd>RECT :> rect
+
+ desktop-monitor-info
+ triple GetDesktopWindow find-devmode
+ hwnd set-fullscreen-styles
+ fullscreen-mode
+
+ hwnd triple set-fullscreen-window-position
+ rect ;
+
+:: set-window-position ( hwnd rect -- )
+ hwnd f rect get-RECT-dimensions SWP_FRAMECHANGED
+ SetWindowPos win32-error=0/f ;
+
+:: disable-fullscreen ( rect triple hwnd -- )
+ desktop-monitor-info
+ triple
+ GetDesktopWindow find-devmode non-fullscreen-mode
+ hwnd set-non-fullscreen-styles
+ hwnd rect set-window-position ;
+
+: enable-factor-fullscreen ( triple -- rect )
+ GetForegroundWindow enable-fullscreen ;
+
+: disable-factor-fullscreen ( rect triple -- )
+ GetForegroundWindow disable-fullscreen ;
+
+:: (set-fullscreen) ( world triple fullscreen? -- )
+ world fullscreen?>> fullscreen? xor [
+ triple
+ world handle>> hWnd>>
+ fullscreen? [
+ enable-fullscreen world (>>saved-position)
+ ] [
+ [ world saved-position>> ] 2dip disable-fullscreen
+ ] if
+ fullscreen? world (>>fullscreen?)
+ ] when ;
+
+: set-fullscreen ( gadget triple fullscreen? -- )
+ [ find-world ] 2dip (set-fullscreen) ;
: (run-loop) ( loop -- )
dup running?>>
- [ [ MAX-FRAMES-TO-SKIP ?tick ] [ redraw ] [ 1 milliseconds sleep (run-loop) ] tri ]
+ [ [ MAX-FRAMES-TO-SKIP ?tick ] [ redraw ] [ yield (run-loop) ] tri ]
[ drop ] if ;
: run-loop ( loop -- )
string>value value>hand-name ;
SYNTAX: HAND{
- "}" parse-tokens [ card> ] { } map-as suffix! ;
+ "}" [ card> ] map-tokens suffix! ;
--- /dev/null
+Doug Coleman
--- /dev/null
+! Copyright (C) 2010 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax ;
+IN: slots.syntax
+
+HELP: slots[
+{ $description "Outputs several slot values to the stack." }
+{ $example "USING: kernel prettyprint slots.syntax ;"
+ "IN: slots.syntax.example"
+ "TUPLE: rectangle width height ;"
+ "T{ rectangle { width 3 } { height 5 } } slots[ width height ] [ . ] bi@"
+ """3
+5"""
+} ;
+
+HELP: slots{
+{ $description "Outputs an array of slot values from a tuple." }
+{ $example "USING: prettyprint slots.syntax ;"
+ "IN: slots.syntax.example"
+ "TUPLE: rectangle width height ;"
+ "T{ rectangle { width 3 } { height 5 } } slots{ width height } ."
+ "{ 3 5 }"
+} ;
+
+ARTICLE: "slots.syntax" "Slots syntax sugar"
+"The " { $vocab-link "slots.syntax" } " vocabulary provides an alternative syntax for taking a sequence of slots from a tuple." $nl
+"Syntax sugar for cleaving slots to the stack:"
+{ $subsections POSTPONE: slots[ }
+"Syntax sugar for cleaving slots to an array:"
+{ $subsections POSTPONE: slots{ } ;
+
+ABOUT: "slots.syntax"
--- /dev/null
+! Copyright (C) 2010 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test slots.syntax ;
+IN: slots.syntax.tests
+
+TUPLE: slot-test a b c ;
+
+[ 1 2 3 ] [ T{ slot-test f 1 2 3 } slots[ a b c ] ] unit-test
+[ 3 ] [ T{ slot-test f 1 2 3 } slots[ c ] ] unit-test
+[ ] [ T{ slot-test f 1 2 3 } slots[ ] ] unit-test
+
+[ { 1 2 3 } ] [ T{ slot-test f 1 2 3 } slots{ a b c } ] unit-test
+[ { 3 } ] [ T{ slot-test f 1 2 3 } slots{ c } ] unit-test
+[ { } ] [ T{ slot-test f 1 2 3 } slots{ } ] unit-test
--- /dev/null
+! Copyright (C) 2010 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: combinators combinators.smart fry lexer quotations
+sequences slots ;
+IN: slots.syntax
+
+SYNTAX: slots[
+ "]" [ reader-word 1quotation ] map-tokens
+ '[ _ cleave ] append! ;
+
+SYNTAX: slots{
+ "}" [ reader-word 1quotation ] map-tokens
+ '[ [ _ cleave ] output>array ] append! ;
[ define-var ] each ;
SYNTAX: VARS: ! vars ...
- ";" parse-tokens define-vars ;
+ ";" [ define-var ] each-token ;
<p>This is the <a href="http://factorcode.org" target="_top">Factor</a>
documentation, generated offline from a
- <code>load-everything</code> image. If you want, you can also browse the
+ <code>load-all</code> image. If you want, you can also browse the
documentation from within the <a href="http://factorcode.org" target="_top">Factor</a> UI.</p>
<p>You may search article titles below; for example, try searching for "HTTP".</p>
special_objects[OBJ_EXECUTABLE] = allot_alien(false_object,(cell)p->executable_path);
special_objects[OBJ_ARGS] = false_object;
special_objects[OBJ_EMBEDDED] = false_object;
+ special_objects[OBJ_VM_COMPILER] = allot_alien(false_object,(cell)FACTOR_COMPILER_VERSION);
/* We can GC now */
gc_off = false;
#include <vector>
#include <iostream>
+#define FACTOR_STRINGIZE(x) #x
+
+/* Record compiler version */
+#if defined(__clang__)
+ #define FACTOR_COMPILER_VERSION "Clang (GCC " __VERSION__ ")"
+#elif defined(__INTEL_COMPILER)
+ #define FACTOR_COMPILER_VERSION "Intel C Compiler " FACTOR_STRINGIZE(__INTEL_COMPILER)
+#elif defined(__GNUC__)
+ #define FACTOR_COMPILER_VERSION "GCC " __VERSION__
+#elif defined(_MSC_FULL_VER)
+ #define FACTOR_COMPILER_VERSION "Microsoft Visual C++ " FACTOR_STRINGIZE(_MSC_FULL_VER)
+#else
+ #define FACTOR_COMPILER_VERSION "unknown"
+#endif
+
/* Detect target CPU type */
#if defined(__arm__)
#define FACTOR_ARM
OBJ_THREADS = 64,
OBJ_RUN_QUEUE = 65,
OBJ_SLEEP_QUEUE = 66,
+
+ OBJ_VM_COMPILER = 67, /* version string of the compiler we were built with */
};
/* save-image-and-exit discards special objects that are filled in on startup
projects / factor.git / commitdiff