M: string stack-size c-type stack-size ;
-M: c-type stack-size size>> ;
+M: c-type stack-size size>> cell align ;
GENERIC: byte-length ( seq -- n ) flushable
"double" define-primitive-type
"long" "ptrdiff_t" typedef
-
+ "long" "intptr_t" typedef
"ulong" "size_t" typedef
] with-compilation-unit
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays generic hashtables kernel kernel.private
-math namespaces parser sequences strings words libc
+math namespaces parser sequences strings words libc fry
alien.c-types alien.structs.fields cpu.architecture ;
IN: alien.structs
-: if-value-structs? ( ctype true false -- )
- value-structs?
- [ drop call ] [ >r 2drop "void*" r> call ] if ; inline
-
TUPLE: struct-type size align fields ;
M: struct-type heap-size size>> ;
M: struct-type c-type-stack-align? drop f ;
-M: struct-type unbox-parameter
- [ %unbox-struct ] [ unbox-parameter ] if-value-structs? ;
+: if-value-struct ( ctype true false -- )
+ [ dup value-struct? ] 2dip '[ drop "void*" @ ] if ; inline
-M: struct-type unbox-return
- f swap %unbox-struct ;
+M: struct-type unbox-parameter
+ [ %unbox-large-struct ] [ unbox-parameter ] if-value-struct ;
M: struct-type box-parameter
- [ %box-struct ] [ box-parameter ] if-value-structs? ;
+ [ %box-large-struct ] [ box-parameter ] if-value-struct ;
+
+: if-small-struct ( c-type true false -- ? )
+ [ dup struct-small-enough? ] 2dip '[ f swap @ ] if ; inline
+
+M: struct-type unbox-return
+ [ %unbox-small-struct ] [ %unbox-large-struct ] if-small-struct ;
M: struct-type box-return
- f swap %box-struct ;
+ [ %box-small-struct ] [ %box-large-struct ] if-small-struct ;
M: struct-type stack-size
- [ heap-size ] [ stack-size ] if-value-structs? ;
+ [ heap-size ] [ stack-size ] if-value-struct ;
: c-struct? ( type -- ? ) (c-type) struct-type? ;
-rot define-c-type ;
: define-struct-early ( name vocab fields -- fields )
- -rot [ rot first2 <field-spec> ] 2curry map ;
+ [ first2 <field-spec> ] with with map ;
: compute-struct-align ( types -- n )
[ c-type-align ] map supremum ;
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: http.client checksums checksums.openssl splitting assocs
+USING: http.client checksums checksums.md5 splitting assocs
kernel io.files bootstrap.image sequences io urls ;
IN: bootstrap.image.download
: need-new-image? ( image -- ? )
dup exists?
[
- [ openssl-md5 checksum-file hex-string ]
+ [ md5 checksum-file hex-string ]
[ download-checksums at ]
bi = not
] [ drop t ] if ;
IN: command-line
HELP: run-bootstrap-init
-{ $description "Runs the " { $snippet ".factor-boot-rc" } " file in the user's home directory unless the " { $snippet "-no-user-init" } " command line switch was given." } ;
+{ $description "Runs the bootstrap initialization file in the user's home directory, unless the " { $snippet "-no-user-init" } " command line switch was given. This file is named " { $snippet ".factor-boot-rc" } " on Unix and " { $snippet "factor-boot-rc" } " on Windows." } ;
HELP: run-user-init
-{ $description "Runs the " { $snippet ".factor-rc" } " file in the user's home directory unless the " { $snippet "-no-user-init" } " command line switch was given." } ;
+{ $description "Runs the startup initialization file in the user's home directory, unless the " { $snippet "-no-user-init" } " command line switch was given. This file is named " { $snippet ".factor-rc" } " on Unix and " { $snippet "factor-rc" } " on Windows." } ;
HELP: cli-param
{ $values { "param" string } }
"A number of command line switches can be passed to a bootstrap image to modify the behavior of the resulting image:"
{ $table
{ { $snippet "-output-image=" { $emphasis "image" } } { "Save the result to " { $snippet "image" } ". The default is " { $snippet "factor.image" } "." } }
- { { $snippet "-no-user-init" } { "Inhibits the running of the " { $snippet ".factor-boot-rc" } " file in the user's home directory." } }
+ { { $snippet "-no-user-init" } { "Inhibits the running of user initialization files on startup. See " { $link "rc-files" } "." } }
{ { $snippet "-include=" { $emphasis "components..." } } "A list of components to include (see below)." }
{ { $snippet "-exclude=" { $emphasis "components..." } } "A list of components to exclude." }
{ { $snippet "-ui-backend=" { $emphasis "backend" } } { "One of " { $snippet "x11" } ", " { $snippet "windows" } ", or " { $snippet "cocoa" } ". The default is platform-specific." } }
"By default, all optional components are loaded. To load all optional components except for a given list, use the " { $snippet "-exclude=" } " switch; to only load specified optional components, use the " { $snippet "-include=" } "."
$nl
"For example, to build an image with the compiler but no other components, you could do:"
-{ $code "./factor -i=boot.ppc.image -include=compiler" }
+{ $code "./factor -i=boot.macosx-ppc.image -include=compiler" }
"To build an image with everything except for the user interface and graphical tools,"
-{ $code "./factor -i=boot.ppc.image -exclude=\"ui ui.tools\"" }
+{ $code "./factor -i=boot.macosx-ppc.image -exclude=\"ui ui.tools\"" }
"To generate a bootstrap image in the first place, see " { $link "bootstrap.image" } "." ;
ARTICLE: "standard-cli-args" "Command line switches for general usage"
{ $table
{ { $snippet "-e=" { $emphasis "code" } } { "This specifies a code snippet to evaluate. If you want Factor to exit immediately after, also specify " { $snippet "-run=none" } "." } }
{ { $snippet "-run=" { $emphasis "vocab" } } { { $snippet { $emphasis "vocab" } } " is the name of a vocabulary with a " { $link POSTPONE: MAIN: } " hook to run on startup, for example " { $vocab-link "listener" } ", " { $vocab-link "ui" } " or " { $vocab-link "none" } "." } }
- { { $snippet "-no-user-init" } { "Inhibits the running of the " { $snippet ".factor-rc" } " file in the user's home directory on startup." } }
+ { { $snippet "-no-user-init" } { "Inhibits the running of user initialization files on startup. See " { $link "rc-files" } "." } }
{ { $snippet "-quiet" } { "If set, " { $link run-file } " and " { $link require } " will not print load messages." } }
{ { $snippet "-script" } { "Equivalent to " { $snippet "-quiet -run=none" } "." $nl "On Unix systems, Factor can be used for scripting - just create an executable text file whose first line is:" { $code "#! /usr/local/bin/factor -script" } "The space after " { $snippet "#!" } " is necessary because of Factor syntax." } }
} ;
+ARTICLE: "factor-boot-rc" "Bootstrap initialization file"
+"The botstrap initialization file is named " { $snippet "factor-boot-rc" } " on Windows and " { $snippet ".factor-boot-rc" } " on Unix. This file can contain " { $link require } " calls for vocabularies you use frequently, and other such long-running tasks that you do not want to perform every time Factor starts."
+$nl
+"A word to run this file from an existing Factor session:"
+{ $subsection run-bootstrap-init }
+"For example, if you changed " { $snippet ".factor-boot-rc" } " and do not want to bootstrap again, you can just invoke " { $link run-bootstrap-init } " in the listener." ;
+
+ARTICLE: "factor-rc" "Startup initialization file"
+"The startup initialization file is named " { $snippet "factor-rc" } " on Windows and " { $snippet ".factor-rc" } " on Unix. If it exists, it is run every time Factor starts."
+$nl
+"A word to run this file from an existing Factor session:"
+{ $subsection run-user-init } ;
+
ARTICLE: "rc-files" "Running code on startup"
-"Unless the " { $snippet "-no-user-init" } " command line switch is specified, The startup routine runs the " { $snippet ".factor-rc" } " file in the user's home directory, if it exists. This file can contain initialization and customization for your development environment."
+"Factor looks for two files in your home directory."
+{ $subsection "factor-boot-rc" }
+{ $subsection "factor-rc" }
+"The " { $snippet "-no-user-init" } " command line switch will inhibit the running of these files."
$nl
-"The " { $snippet ".factor-rc" } " and " { $snippet ".factor-boot-rc" } " files can be run explicitly:"
-{ $subsection run-user-init }
-{ $subsection run-bootstrap-init } ;
+"If you are unsure where the files should be located, evaluate the following code:"
+{ $code
+ "USE: command-line"
+ "\"factor-rc\" rc-path print"
+ "\"factor-boot-rc\" rc-path print"
+}
+"Here is an example " { $snippet ".factor-boot-rc" } " which sets up GVIM editor integration, adds an additional vocabulary root (see " { $link "vocabs.roots" } "), and increases the font size in the UI by setting the DPI (dots-per-inch) variable:"
+{ $code
+ "USING: editors.gvim vocabs.loader ui.freetype namespaces sequences ;"
+ "\"/opt/local/bin\" \\ gvim-path set-global"
+ "\"/home/jane/src/\" vocab-roots get push"
+ "100 dpi set-global"
+} ;
ARTICLE: "cli" "Command line usage"
"Zero or more command line arguments may be passed to the Factor runtime. Command line arguments starting with a dash (" { $snippet "-" } ") is interpreted as switches. All other arguments are taken to be file names to be run by " { $link run-file } "."
splitting io.files eval ;
IN: command-line
+: rc-path ( name -- path )
+ os windows? [ "." prepend ] unless
+ home prepend-path ;
+
: run-bootstrap-init ( -- )
"user-init" get [
- home ".factor-boot-rc" append-path ?run-file
+ "factor-boot-rc" rc-path ?run-file
] when ;
: run-user-init ( -- )
"user-init" get [
- home ".factor-rc" append-path ?run-file
+ "factor-rc" rc-path ?run-file
] when ;
: cli-var-param ( name value -- ) swap set-global ;
GENERIC: inc-reg-class ( register-class -- )
: ?dummy-stack-params ( reg-class -- )
- dummy-stack-params? [ reg-size stack-params +@ ] [ drop ] if ;
+ dummy-stack-params? [ reg-size cell align stack-params +@ ] [ drop ] if ;
: ?dummy-int-params ( reg-class -- )
dummy-int-params? [ reg-size cell /i 1 max int-regs +@ ] [ drop ] if ;
: spill-param ( reg-class -- n reg-class )
stack-params get
- >r reg-size stack-params +@ r>
+ >r reg-size cell align stack-params +@ r>
stack-params ;
: fastcall-param ( reg-class -- n reg-class )
{ $description "Enables the optimizing compiler." } ;
HELP: disable-compiler
-{ $description "Enables the optimizing compiler." } ;
+{ $description "Disable the optimizing compiler." } ;
ARTICLE: "compiler-usage" "Calling the optimizing compiler"
"Normally, new word definitions are recompiled automatically. This can be changed:"
! Make sure XT doesn't get clobbered in stack frame
-: ffi_test_31 ( a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a ptr -- result y )
- "void"
+: ffi_test_31 ( a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a -- result y )
+ "int"
f "ffi_test_31"
{ "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" }
alien-invoke gc 3 ;
-[ 3 ] [ 42 [ ] each ffi_test_31 ] unit-test
+[ 861 3 ] [ 42 [ ] each ffi_test_31 ] unit-test
+
+: ffi_test_31_point_5 ( a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a -- result )
+ "float"
+ f "ffi_test_31_point_5"
+ { "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" }
+ alien-invoke ;
+
+[ 861.0 ] [ 42 [ >float ] each ffi_test_31_point_5 ] unit-test
FUNCTION: longlong ffi_test_21 long x long y ;
if ;
: (build-tree-from-word) ( word -- )
- dup
- [ "inline" word-prop ]
- [ "recursive" word-prop ] bi and [
- 1quotation f initial-recursive-state infer-quot
- ] [
- [ specialized-def ] [ initial-recursive-state ] bi
- infer-quot
- ] if ;
+ dup initial-recursive-state recursive-state set
+ dup [ "inline" word-prop ] [ "recursive" word-prop ] bi and
+ [ 1quotation ] [ specialized-def ] if
+ infer-quot-here ;
: check-cannot-infer ( word -- )
dup "cannot-infer" word-prop [ cannot-infer-effect ] [ drop ] if ;
HOOK: small-enough? cpu ( n -- ? )
! Is this structure small enough to be returned in registers?
-HOOK: struct-small-enough? cpu ( heap-size -- ? )
+HOOK: struct-small-enough? cpu ( c-type -- ? )
-! Do we pass value structs by value or hidden reference?
-HOOK: value-structs? cpu ( -- ? )
+! Do we pass this struct by value or hidden reference?
+HOOK: value-struct? cpu ( c-type -- ? )
! If t, all parameters are shadowed by dummy stack parameters
HOOK: dummy-stack-params? cpu ( -- ? )
M: stack-params param-reg drop ;
M: stack-params param-regs drop f ;
-
-: if-small-struct ( n size true false -- ? )
- [ 2dup [ not ] [ struct-small-enough? ] bi* and ] 2dip
- [ '[ nip @ ] ] dip if ;
- inline
-
-: %unbox-struct ( n c-type -- )
- [ %unbox-small-struct ] [ %unbox-large-struct ] if-small-struct ;
-
-: %box-struct ( n c-type -- )
- [ %box-small-struct ] [ %box-large-struct ] if-small-struct ;
M: float-regs param-regs drop { 1 2 3 4 5 6 7 8 } ;
-M: ppc value-structs? f ;
+M: ppc value-struct? drop f ;
M: ppc dummy-stack-params? f ;
M: float-regs param-regs drop { 1 2 3 4 5 6 7 8 9 10 11 12 13 } ;
-M: ppc value-structs? t ;
+M: ppc value-struct? drop t ;
M: ppc dummy-stack-params? t ;
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel layouts system math alien.c-types
+USING: kernel layouts system math alien.c-types sequences
compiler.cfg.registers cpu.architecture cpu.x86.assembler cpu.x86 ;
IN: cpu.x86.64.winnt
M: x86.64 reserved-area-size 4 cells ;
-M: x86.64 struct-small-enough? ( size -- ? )
- heap-size cell <= ;
+M: x86.64 struct-small-enough? heap-size { 1 2 4 8 } member? ;
+
+M: x86.64 value-struct? heap-size { 1 2 4 8 } member? ;
M: x86.64 dummy-stack-params? f ;
<<
"longlong" "ptrdiff_t" typedef
+"longlong" "intptr_t" typedef
"int" "long" typedef
"uint" "ulong" typedef
>>
temp-reg-1 2 cells [+] ds-reg MOV
temp-reg-1 3 cells [+] rs-reg MOV ;
-M: x86 value-structs? t ;
+M: x86 value-struct? drop t ;
M: x86 small-enough? ( n -- ? )
HEX: -80000000 HEX: 7fffffff between? ;
USING: definitions io.launcher kernel parser words sequences math
-math.parser namespaces editors make ;
+math.parser namespaces editors make system ;
IN: editors.emacs
: emacsclient ( file line -- )
[
\ emacsclient get "emacsclient" or ,
- "--no-wait" ,
+ os windows? [ "--no-wait" , ] unless
"+" swap number>string append ,
,
] { } make try-process ;
{ "FT_Pos" "advance-x" }
{ "FT_Pos" "advance-y" }
- { "long" "format" }
+ { "intptr_t" "format" }
{ "int" "bitmap-rows" }
{ "int" "bitmap-width" }
furnace.db
furnace.cache
furnace.asides
-furnace.referrer
furnace.sessions
furnace.conversations
furnace.auth.providers
<conversations>
<sessions>
] dip
- <db-persistence>
- <check-form-submissions> ;
+ <db-persistence> ;
: start-expiring ( db -- )
'[
</table>
<p>
- <button>Update</button>
+ <button type="submit">Update</button>
<t:validation-errors />
</p>
</table>
- <button>Recover password</button>
+ <button type="submit">Recover password</button>
</t:form>
</table>
<p>
- <button>Set password</button>
+ <button type="submit">Set password</button>
<t:validation-errors />
</p>
<p>
- <button>Register</button>
+ <button type="submit">Register</button>
<t:validation-errors />
</p>
<p>
- <button>Log in</button>
+ <button type="submit">Log in</button>
<t:validation-errors />
</p>
{ $notes "Furnace actions and authentication realms wrap their execution in this combinator, allowing form validation failures and login requests, respectively, to immediately return an HTTP response to the client without running any more responder code." } ;
ARTICLE: "furnace.extension-points" "Furnace extension points"
-"Furnace features such as session management, conversation scope and asides need to modify URLs in links and redirects, and insert hidden form fields, to implement state on top of the setateless HTTP protocol. In order to decouple the server-side state management code from the HTML templating code, a series of hooks are used."
+"Furnace features such as session management, conversation scope and asides need to modify URLs in links and redirects, and insert hidden form fields, to implement state on top of the stateless HTTP protocol. In order to decouple the server-side state management code from the HTML templating code, a series of hooks are used."
$nl
"Responders can implement methods on the following generic words:"
{ $subsection modify-query }
: escape-char ( ch -- )
dup H{
- { CHAR: " "__quote__" }
+ { CHAR: " "__quo__" }
{ CHAR: * "__star__" }
{ CHAR: : "__colon__" }
{ CHAR: < "__lt__" }
{ CHAR: > "__gt__" }
- { CHAR: ? "__question__" }
- { CHAR: \\ "__backslash__" }
+ { CHAR: ? "__que__" }
+ { CHAR: \\ "__back__" }
{ CHAR: | "__pipe__" }
- { CHAR: _ "__underscore__" }
{ CHAR: / "__slash__" }
- { CHAR: \\ "__backslash__" }
{ CHAR: , "__comma__" }
{ CHAR: @ "__at__" }
} at [ % ] [ , ] ?if ;
[ [ title>> ] compare ] sort ;
: article-apropos ( string -- results )
- "articles.idx" temp-file offline-apropos ;
+ "articles.idx" offline-apropos ;
: word-apropos ( string -- results )
- "words.idx" temp-file offline-apropos ;
+ "words.idx" offline-apropos ;
: vocab-apropos ( string -- results )
- "vocabs.idx" temp-file offline-apropos ;
+ "vocabs.idx" offline-apropos ;
USING: io io.files io.streams.string io.encodings.utf8
html.templates html.templates.fhtml kernel
-tools.test sequences parser ;
+tools.test sequences parser splitting prettyprint ;
IN: html.templates.fhtml.tests
: test-template ( path -- ? )
prepend
[
".fhtml" append <fhtml> [ call-template ] with-string-writer
+ <string-reader> lines
] keep
- ".html" append utf8 file-contents = ;
+ ".html" append utf8 file-lines
+ [ . . ] [ = ] 2bi ;
[ t ] [ "example" test-template ] unit-test
[ t ] [ "bug" test-template ] unit-test
USING: tools.test io.files.listing strings kernel ;
IN: io.files.listing.tests
+\ directory. must-infer
+
[ ] [ "" directory. ] unit-test
] when*
] unless ;
+: (start-server) ( threaded-server -- )
+ init-server
+ dup threaded-server [
+ dup name>> [
+ [ listen-on [ start-accept-loop ] parallel-each ]
+ [ ready>> raise-flag ]
+ bi
+ ] with-logging
+ ] with-variable ;
+
PRIVATE>
: start-server ( threaded-server -- )
- init-server
- dup secure-config>> [
- dup threaded-server [
- dup name>> [
- [ listen-on [ start-accept-loop ] parallel-each ]
- [ ready>> raise-flag ]
- bi
- ] with-logging
- ] with-variable
- ] with-secure-context ;
+ #! Only create a secure-context if we want to listen on
+ #! a secure port, otherwise start-server won't work at
+ #! all if SSL is not available.
+ dup secure>> [
+ dup secure-config>> [
+ (start-server)
+ ] with-secure-context
+ ] [
+ (start-server)
+ ] if ;
: wait-for-server ( threaded-server -- )
ready>> wait-for-flag ;
-USING: io.launcher tools.test calendar accessors environment\r
-namespaces kernel system arrays io io.files io.encodings.ascii\r
-sequences parser assocs hashtables math continuations eval ;\r
-IN: io.windows.launcher.nt.tests\r
-\r
-[ ] [\r
- <process>\r
- "notepad" >>command\r
- 1/2 seconds >>timeout\r
- "notepad" set\r
-] unit-test\r
-\r
-[ f ] [ "notepad" get process-running? ] unit-test\r
-\r
-[ f ] [ "notepad" get process-started? ] unit-test\r
-\r
-[ ] [ "notepad" [ run-detached ] change ] unit-test\r
-\r
-[ "notepad" get wait-for-process ] must-fail\r
-\r
-[ t ] [ "notepad" get killed>> ] unit-test\r
-\r
-[ f ] [ "notepad" get process-running? ] unit-test\r
-\r
-[ ] [\r
- <process>\r
- vm "-quiet" "-run=hello-world" 3array >>command\r
- "out.txt" temp-file >>stdout\r
- try-process\r
-] unit-test\r
-\r
-[ "Hello world" ] [\r
- "out.txt" temp-file ascii file-lines first\r
-] unit-test\r
-\r
-[ ] [\r
- <process>\r
- vm "-run=listener" 2array >>command\r
- +closed+ >>stdin\r
- try-process\r
-] unit-test\r
-\r
-[ ] [\r
- "resource:basis/io/windows/nt/launcher/test" [\r
- <process>\r
- vm "-script" "stderr.factor" 3array >>command\r
- "out.txt" temp-file >>stdout\r
- "err.txt" temp-file >>stderr\r
- try-process\r
- ] with-directory\r
-] unit-test\r
-\r
-[ "output" ] [\r
- "out.txt" temp-file ascii file-lines first\r
-] unit-test\r
-\r
-[ "error" ] [\r
- "err.txt" temp-file ascii file-lines first\r
-] unit-test\r
-\r
-[ ] [\r
- "resource:basis/io/windows/nt/launcher/test" [\r
- <process>\r
- vm "-script" "stderr.factor" 3array >>command\r
- "out.txt" temp-file >>stdout\r
- +stdout+ >>stderr\r
- try-process\r
- ] with-directory\r
-] unit-test\r
-\r
-[ "outputerror" ] [\r
- "out.txt" temp-file ascii file-lines first\r
-] unit-test\r
-\r
-[ "output" ] [\r
- "resource:basis/io/windows/nt/launcher/test" [\r
- <process>\r
- vm "-script" "stderr.factor" 3array >>command\r
- "err2.txt" temp-file >>stderr\r
- ascii <process-reader> lines first\r
- ] with-directory\r
-] unit-test\r
-\r
-[ "error" ] [\r
- "err2.txt" temp-file ascii file-lines first\r
-] unit-test\r
-\r
-[ t ] [\r
- "resource:basis/io/windows/nt/launcher/test" [\r
- <process>\r
- vm "-script" "env.factor" 3array >>command\r
- ascii <process-reader> contents\r
- ] with-directory eval\r
-\r
- os-envs =\r
-] unit-test\r
-\r
-[ t ] [\r
- "resource:basis/io/windows/nt/launcher/test" [\r
- <process>\r
- vm "-script" "env.factor" 3array >>command\r
- +replace-environment+ >>environment-mode\r
- os-envs >>environment\r
- ascii <process-reader> contents\r
- ] with-directory eval\r
- \r
- os-envs =\r
-] unit-test\r
-\r
-[ "B" ] [\r
- "resource:basis/io/windows/nt/launcher/test" [\r
- <process>\r
- vm "-script" "env.factor" 3array >>command\r
- { { "A" "B" } } >>environment\r
- ascii <process-reader> contents\r
- ] with-directory eval\r
-\r
- "A" swap at\r
-] unit-test\r
-\r
-[ f ] [\r
- "resource:basis/io/windows/nt/launcher/test" [\r
- <process>\r
- vm "-script" "env.factor" 3array >>command\r
- { { "HOME" "XXX" } } >>environment\r
- +prepend-environment+ >>environment-mode\r
- ascii <process-reader> contents\r
- ] with-directory eval\r
-\r
- "HOME" swap at "XXX" =\r
-] unit-test\r
-\r
-2 [\r
- [ ] [\r
- <process>\r
- "cmd.exe /c dir" >>command\r
- "dir.txt" temp-file >>stdout\r
- try-process\r
- ] unit-test\r
-\r
- [ ] [ "dir.txt" temp-file delete-file ] unit-test\r
-] times\r
-\r
-[ "append-test" temp-file delete-file ] ignore-errors\r
-\r
-[ "Hello appender\r\nHello appender\r\n" ] [\r
- 2 [\r
- "resource:basis/io/windows/nt/launcher/test" [\r
- <process>\r
- vm "-script" "append.factor" 3array >>command\r
- "append-test" temp-file <appender> >>stdout\r
- try-process\r
- ] with-directory\r
- ] times\r
- \r
- "append-test" temp-file ascii file-contents\r
-] unit-test\r
+USING: io.launcher tools.test calendar accessors environment
+namespaces kernel system arrays io io.files io.encodings.ascii
+sequences parser assocs hashtables math continuations eval ;
+IN: io.windows.launcher.nt.tests
+
+[ ] [
+ <process>
+ "notepad" >>command
+ 1/2 seconds >>timeout
+ "notepad" set
+] unit-test
+
+[ f ] [ "notepad" get process-running? ] unit-test
+
+[ f ] [ "notepad" get process-started? ] unit-test
+
+[ ] [ "notepad" [ run-detached ] change ] unit-test
+
+[ "notepad" get wait-for-process ] must-fail
+
+[ t ] [ "notepad" get killed>> ] unit-test
+
+[ f ] [ "notepad" get process-running? ] unit-test
+
+[ ] [
+ <process>
+ vm "-quiet" "-run=hello-world" 3array >>command
+ "out.txt" temp-file >>stdout
+ try-process
+] unit-test
+
+[ "Hello world" ] [
+ "out.txt" temp-file ascii file-lines first
+] unit-test
+
+[ ] [
+ <process>
+ vm "-run=listener" 2array >>command
+ +closed+ >>stdin
+ try-process
+] unit-test
+
+[ ] [
+ "resource:basis/io/windows/nt/launcher/test" [
+ <process>
+ vm "-script" "stderr.factor" 3array >>command
+ "out.txt" temp-file >>stdout
+ "err.txt" temp-file >>stderr
+ try-process
+ ] with-directory
+] unit-test
+
+[ "output" ] [
+ "out.txt" temp-file ascii file-lines first
+] unit-test
+
+[ "error" ] [
+ "err.txt" temp-file ascii file-lines first
+] unit-test
+
+[ ] [
+ "resource:basis/io/windows/nt/launcher/test" [
+ <process>
+ vm "-script" "stderr.factor" 3array >>command
+ "out.txt" temp-file >>stdout
+ +stdout+ >>stderr
+ try-process
+ ] with-directory
+] unit-test
+
+[ "outputerror" ] [
+ "out.txt" temp-file ascii file-lines first
+] unit-test
+
+[ "output" ] [
+ "resource:basis/io/windows/nt/launcher/test" [
+ <process>
+ vm "-script" "stderr.factor" 3array >>command
+ "err2.txt" temp-file >>stderr
+ ascii <process-reader> lines first
+ ] with-directory
+] unit-test
+
+[ "error" ] [
+ "err2.txt" temp-file ascii file-lines first
+] unit-test
+
+[ t ] [
+ "resource:basis/io/windows/nt/launcher/test" [
+ <process>
+ vm "-script" "env.factor" 3array >>command
+ ascii <process-reader> contents
+ ] with-directory eval
+
+ os-envs =
+] unit-test
+
+[ t ] [
+ "resource:basis/io/windows/nt/launcher/test" [
+ <process>
+ vm "-script" "env.factor" 3array >>command
+ +replace-environment+ >>environment-mode
+ os-envs >>environment
+ ascii <process-reader> contents
+ ] with-directory eval
+
+ os-envs =
+] unit-test
+
+[ "B" ] [
+ "resource:basis/io/windows/nt/launcher/test" [
+ <process>
+ vm "-script" "env.factor" 3array >>command
+ { { "A" "B" } } >>environment
+ ascii <process-reader> contents
+ ] with-directory eval
+
+ "A" swap at
+] unit-test
+
+[ f ] [
+ "resource:basis/io/windows/nt/launcher/test" [
+ <process>
+ vm "-script" "env.factor" 3array >>command
+ { { "USERPROFILE" "XXX" } } >>environment
+ +prepend-environment+ >>environment-mode
+ ascii <process-reader> contents
+ ] with-directory eval
+
+ "USERPROFILE" swap at "XXX" =
+] unit-test
+
+2 [
+ [ ] [
+ <process>
+ "cmd.exe /c dir" >>command
+ "dir.txt" temp-file >>stdout
+ try-process
+ ] unit-test
+
+ [ ] [ "dir.txt" temp-file delete-file ] unit-test
+] times
+
+[ "append-test" temp-file delete-file ] ignore-errors
+
+[ "Hello appender\r\nHello appender\r\n" ] [
+ 2 [
+ "resource:basis/io/windows/nt/launcher/test" [
+ <process>
+ vm "-script" "append.factor" 3array >>command
+ "append-test" temp-file <appender> >>stdout
+ try-process
+ ] with-directory
+ ] times
+
+ "append-test" temp-file ascii file-contents
+] unit-test
{ 3 1 } [| from to seq | T{ slice f from to seq } ] must-infer-as
-
:: literal-identity-test ( -- a b )
{ } V{ } ;
swapd [ eq? ] [ eq? ] 2bi*
] unit-test
+:: mutable-local-in-literal-test ( a! -- b ) a 1 + a! { a } ;
+
+[ { 4 } ] [ 3 mutable-local-in-literal-test ] unit-test
+
:: compare-case ( obj1 obj2 lt-quot eq-quot gt-quot -- )
obj1 obj2 <=> {
{ +lt+ [ lt-quot call ] }
M: local rewrite-element , ;
+M: local-reader rewrite-element , ;
+
M: word rewrite-element literalize , ;
M: object rewrite-element , ;
! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel math math.functions sequences
sequences.private words namespaces macros hints
-combinators fry ;
+combinators fry io.binary ;
IN: math.bitwise
! utilities
: bit-count ( x -- n )
dup 0 < [ bitnot ] when (bit-count) ; inline
+
+! Signed byte array to integer conversion
+: signed-le> ( bytes -- x )
+ [ le> ] [ length 8 * 1- on-bits ] bi
+ 2dup > [ bitnot bitor ] [ drop ] if ;
+
+: signed-be> ( bytes -- x )
+ <reversed> signed-le> ;
PRIVATE>
: rect> ( x y -- z )
- over real? over real? and [
+ 2dup [ real? ] both? [
(rect>)
] [
"Complex number must have real components" throw
>float dup 0.0 < [ neg fsqrt 0.0 swap rect> ] [ fsqrt ] if ;
: each-bit ( n quot: ( ? -- ) -- )
- over 0 = pick -1 = or [
+ over [ 0 = ] [ -1 = ] bi or [
2drop
] [
- 2dup >r >r >r odd? r> call r> 2/ r> each-bit
+ 2dup { [ odd? ] [ call ] [ 2/ ] [ each-bit ] } spread
] if ; inline recursive
: map-bits ( n quot: ( ? -- obj ) -- seq )
>rect [ >float ] bi@ ; inline
: >polar ( z -- abs arg )
- >float-rect [ [ sq ] bi@ + fsqrt ] [ swap fatan2 ] 2bi ;
- inline
+ >float-rect [ [ sq ] bi@ + fsqrt ] [ swap fatan2 ] 2bi ; inline
: cis ( arg -- z ) dup fcos swap fsin rect> ; inline
<PRIVATE
: ^mag ( w abs arg -- magnitude )
- >r >r >float-rect swap r> swap fpow r> rot * fexp /f ;
- inline
+ [ >float-rect swap ] [ swap fpow ] [ rot * fexp /f ] tri* ; inline
: ^theta ( w abs arg -- theta )
- >r >r >float-rect r> flog * swap r> * + ; inline
+ [ >float-rect ] [ flog * swap ] [ * + ] tri* ; inline
: ^complex ( x y -- z )
swap >polar [ ^mag ] [ ^theta ] 3bi polar> ; inline
: (^mod) ( n x y -- z )
1 swap [
- [ dupd * pick mod ] when >r sq over mod r>
+ [ dupd * pick mod ] when [ sq over mod ] dip
] each-bit 2nip ; inline
: (gcd) ( b a x y -- a d )
over zero? [
2nip
] [
- swap [ /mod >r over * swapd - r> ] keep (gcd)
+ swap [ /mod [ over * swapd - ] dip ] keep (gcd)
] if ;
: gcd ( x y -- a d )
- 0 -rot 1 -rot (gcd) dup 0 < [ neg ] when ; foldable
+ [ 0 1 ] 2dip (gcd) dup 0 < [ neg ] when ; foldable
: lcm ( a b -- c )
[ * ] 2keep gcd nip /i ; foldable
: ^mod ( x y n -- z )
over 0 < [
- [ >r neg r> ^mod ] keep mod-inv
+ [ [ neg ] dip ^mod ] keep mod-inv
] [
-rot (^mod)
] if ; foldable
M: real absq sq ;
: ~abs ( x y epsilon -- ? )
- >r - abs r> < ;
+ [ - abs ] dip < ;
: ~rel ( x y epsilon -- ? )
- >r [ - abs ] 2keep [ abs ] bi@ + r> * < ;
+ [ [ - abs ] 2keep [ abs ] bi@ + ] dip * < ;
: ~ ( x y epsilon -- ? )
{
- { [ pick fp-nan? pick fp-nan? or ] [ 3drop f ] }
+ { [ 2over [ fp-nan? ] either? ] [ 3drop f ] }
{ [ dup zero? ] [ drop number= ] }
{ [ dup 0 < ] [ ~rel ] }
[ ~abs ]
TUPLE: interval { from read-only } { to read-only } ;
: <interval> ( from to -- int )
- over first over first {
+ 2dup [ first ] bi@ {
{ [ 2dup > ] [ 2drop 2drop empty-interval ] }
{ [ 2dup = ] [
- 2drop over second over second and
+ 2drop 2dup [ second ] both?
[ interval boa ] [ 2drop empty-interval ] if
] }
[ 2drop interval boa ]
: closed-point ( n -- endpoint ) t 2array ;
: [a,b] ( a b -- interval )
- >r closed-point r> closed-point <interval> ; foldable
+ [ closed-point ] dip closed-point <interval> ; foldable
: (a,b) ( a b -- interval )
- >r open-point r> open-point <interval> ; foldable
+ [ open-point ] dip open-point <interval> ; foldable
: [a,b) ( a b -- interval )
- >r closed-point r> open-point <interval> ; foldable
+ [ closed-point ] dip open-point <interval> ; foldable
: (a,b] ( a b -- interval )
- >r open-point r> closed-point <interval> ; foldable
+ [ open-point ] dip closed-point <interval> ; foldable
: [a,a] ( a -- interval )
closed-point dup <interval> ; foldable
: [-inf,inf] ( -- interval ) full-interval ; inline
: compare-endpoints ( p1 p2 quot -- ? )
- >r over first over first r> call [
+ [ 2dup [ first ] bi@ ] dip call [
2drop t
] [
- over first over first = [
- swap second swap second not or
+ 2dup [ first ] bi@ = [
+ [ second ] bi@ not or
] [
2drop f
] if
] if ;
: (interval-op) ( p1 p2 quot -- p3 )
- [ [ first ] [ first ] [ ] tri* call ]
+ [ [ first ] [ first ] [ call ] tri* ]
[ drop [ second ] both? ]
3bi 2array ; inline
drop f
] [
interval>points
- 2dup [ second ] bi@ and
+ 2dup [ second ] both?
[ [ first ] bi@ = ]
[ 2drop f ] if
] if ;
dup [ interval>points [ first ] bi@ [a,b] ] when ;
: interval-integer-op ( i1 i2 quot -- i3 )
- >r 2dup
- [ interval>points [ first integer? ] both? ] both?
- r> [ 2drop [-inf,inf] ] if ; inline
+ [
+ 2dup [ interval>points [ first integer? ] both? ] both?
+ ] dip [ 2drop [-inf,inf] ] if ; inline
: interval-shift ( i1 i2 -- i3 )
#! Inaccurate; could be tighter
2tri and and ;
: (interval<) ( i1 i2 -- i1 i2 ? )
- over from>> over from>> endpoint< ;
+ 2dup [ from>> ] bi@ endpoint< ;
: interval< ( i1 i2 -- ? )
{
} cond 2nip ;
: left-endpoint-<= ( i1 i2 -- ? )
- >r from>> r> to>> = ;
+ [ from>> ] dip to>> = ;
: right-endpoint-<= ( i1 i2 -- ? )
- >r to>> r> from>> = ;
+ [ to>> ] dip from>> = ;
: interval<= ( i1 i2 -- ? )
{
: math-method* ( word left right -- quot )
3dup math-op
- [ >r 3drop r> 1quotation ] [ drop math-method ] if ;
+ [ [ 3drop ] dip 1quotation ] [ drop math-method ] if ;
: math-both-known? ( word left right -- ? )
3dup math-op
] bi@ append ;
: each-derived-op ( word quot -- )
- >r derived-ops r> each ; inline
+ [ derived-ops ] dip each ; inline
: each-fast-derived-op ( word quot -- )
- >r fast-derived-ops r> each ; inline
+ [ fast-derived-ops ] dip each ; inline
: each-integer-derived-op ( word quot -- )
- >r integer-derived-ops r> each ; inline
+ [ integer-derived-ops ] dip each ; inline
[
[
{ step read-only } ;
: <range> ( a b step -- range )
- >r over - r>
+ [ over - ] dip
[ / 1+ 0 max >integer ] keep
range boa ; inline
dup 1 number= [ drop ] [ <ratio> ] if ; inline
: scale ( a/b c/d -- a*d b*c )
- 2>fraction >r * swap r> * swap ; inline
+ 2>fraction [ * swap ] dip * swap ; inline
: ratio+d ( a/b c/d -- b*d )
- denominator swap denominator * ; inline
+ [ denominator ] bi@ * ; inline
PRIVATE>
"Division by zero" throw
] [
dup 0 < [ [ neg ] bi@ ] when
- 2dup gcd nip tuck /i >r /i r> fraction>
+ 2dup gcd nip tuck /i [ /i ] dip fraction>
] if ;
M: ratio hashcode*
M: ratio + 2dup scale + -rot ratio+d / ;
M: ratio - 2dup scale - -rot ratio+d / ;
-M: ratio * 2>fraction * >r * r> / ;
+M: ratio * 2>fraction * [ * ] dip / ;
M: ratio / scale / ;
M: ratio /i scale /i ;
M: ratio /f scale /f ;
{ $description "Multiplies each element of " { $snippet "u" } " by " { $snippet "n" } "." } ;
HELP: v*n
-{ $values { "n" "a number" } { "u" "a sequence of numbers" } { "v" "a sequence of numbers" } }
+{ $values { "u" "a sequence of numbers" } { "n" "a number" } { "v" "a sequence of numbers" } }
{ $description "Multiplies each element of " { $snippet "u" } " by " { $snippet "n" } "." } ;
HELP: n/v
: normalize ( u -- v ) dup norm v/n ;
: set-axis ( u v axis -- w )
- [ >r zero? 2over ? r> swap nth ] map-index 2nip ;
+ [ [ zero? 2over ? ] dip swap nth ] map-index 2nip ;
HINTS: vneg { array } ;
HINTS: norm-sq { array } ;
over glEnableClientState dip glDisableClientState ; inline
: words>values ( word/value-seq -- value-seq )
- [ dup word? [ execute ] [ ] if ] map ;
+ [ dup word? [ execute ] when ] map ;
: (all-enabled) ( seq quot -- )
over [ glEnable ] each dip [ glDisable ] each ; inline
[ 2 GL_FLOAT 0 ] dip glTexCoordPointer ; inline
: line-vertices ( a b -- )
- append >c-float-array gl-vertex-pointer ;
+ [ first2 [ 0.5 + ] bi@ ] bi@ 4 narray
+ >c-float-array gl-vertex-pointer ;
: gl-line ( a b -- )
line-vertices GL_LINES 0 2 glDrawArrays ;
: (rect-vertices) ( dim -- vertices )
{
- [ drop 0 1 ]
- [ first 1- 1 ]
- [ [ first 1- ] [ second ] bi ]
- [ second 0 swap ]
+ [ drop 0.5 0.5 ]
+ [ first 0.3 - 0.5 ]
+ [ [ first 0.3 - ] [ second 0.3 - ] bi ]
+ [ second 0.3 - 0.5 swap ]
} cleave 8 narray >c-float-array ;
: rect-vertices ( dim -- )
[ ] [ \ curry see ] unit-test
[ "POSTPONE: [" ] [ \ [ unparse ] unit-test
+
+TUPLE: started-out-hustlin' ;
+
+GENERIC: ended-up-ballin'
+
+M: started-out-hustlin' ended-up-ballin' ; inline
+
+[ "USING: prettyprint.tests ;\nM: started-out-hustlin' ended-up-ballin' ; inline\n" ] [
+ [ { started-out-hustlin' ended-up-ballin' } see ] with-string-writer
+] unit-test
block>
] with-use nl ;
+M: method-spec see
+ first2 method see ;
+
GENERIC: see-class* ( word -- )
M: union-class see-class*
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors hashtables kernel math state-tables vars vectors ;
+USING: accessors hashtables kernel math state-tables vectors ;
IN: regexp.backend
TUPLE: regexp
M: digit-class class-member? ( obj class -- ? )
drop digit? ;
+M: c-identifier-class class-member? ( obj class -- ? )
+ drop
+ { [ digit? ] [ Letter? ] [ CHAR: _ = ] } 1|| ;
+
M: alpha-class class-member? ( obj class -- ? )
drop alpha? ;
DEFER: (parse-regexp)
: nested-parse-regexp ( token ? -- )
[ push-stack (parse-regexp) pop-stack ] dip
- [ <negation> ] when pop-stack boa push-stack ;
+ [ <negation> ] when pop-stack new swap >>term push-stack ;
! non-capturing groups
: (parse-special-group) ( -- )
read1
{
{ CHAR: \ [ CHAR: \ <constant> ] }
+ { CHAR: / [ CHAR: / <constant> ] }
{ CHAR: ^ [ CHAR: ^ <constant> ] }
{ CHAR: $ [ CHAR: $ <constant> ] }
{ CHAR: - [ CHAR: - <constant> ] }
regexp.traversal eval ;
IN: regexp-tests
+\ <regexp> must-infer
+\ matches? must-infer
+
[ f ] [ "b" "a*" <regexp> matches? ] unit-test
[ t ] [ "" "a*" <regexp> matches? ] unit-test
[ t ] [ "a" "a*" <regexp> matches? ] unit-test
[ t ] [ "a" ".+" <regexp> matches? ] unit-test
[ t ] [ "ab" ".+" <regexp> matches? ] unit-test
+[ t ] [ " " "[\\s]" <regexp> matches? ] unit-test
+[ f ] [ "a" "[\\s]" <regexp> matches? ] unit-test
+[ f ] [ " " "[\\S]" <regexp> matches? ] unit-test
+[ t ] [ "a" "[\\S]" <regexp> matches? ] unit-test
+[ f ] [ " " "[\\w]" <regexp> matches? ] unit-test
+[ t ] [ "a" "[\\w]" <regexp> matches? ] unit-test
+[ t ] [ " " "[\\W]" <regexp> matches? ] unit-test
+[ f ] [ "a" "[\\W]" <regexp> matches? ] unit-test
+
+[ t ] [ "/" "\\/" <regexp> matches? ] unit-test
+
+[ t ] [ "a" R' a'i matches? ] unit-test
[ t ] [ "" "a|b*|c+|d?" <regexp> matches? ] unit-test
[ t ] [ "a" "a|b*|c+|d?" <regexp> matches? ] unit-test
[ { 0 3 } ] [ "abc" "(ab|a)(bc)?" <regexp> first-match ] unit-test
[ { 23 24 } ] [ "aaaaaaaaaaaaaaaaaaaaaaab" "((a*)*b)*b" <regexp> first-match ] unit-test
+
+[ t ] [ "a:b" ".+:?" <regexp> matches? ] unit-test
+
+[ 1 ] [ "hello" ".+?" <regexp> match length ] unit-test
: match ( string regexp -- pair )
<dfa-traverser> do-match return-match ;
-: match* ( string regexp -- pair )
+: match* ( string regexp -- pair captured-groups )
<dfa-traverser> do-match [ return-match ] [ captured-groups>> ] bi ;
: matches? ( string regexp -- ? )
: option? ( option regexp -- ? )
options>> key? ;
-USE: multiline
-/*
M: regexp pprint*
[
[
case-insensitive swap option? [ "i" % ] when
] "" make
] keep present-text ;
-*/
: increment-state ( dfa-traverser state -- dfa-traverser )
[
dup traverse-forward>>
- [ 1+ ] [ 1- ] ? change-current-index
+ [ [ 1+ ] change-current-index ]
+ [ [ 1- ] change-current-index ] if
dup current-state>> >>last-state
] dip
first >>current-state ;
--- /dev/null
+USING: regexp.utils tools.test ;
+IN: regexp.utils.tests
+
+[ [ ] [ ] while-changes ] must-infer
math.ranges fry combinators.short-circuit vectors ;
IN: regexp.utils
-: (while-changes) ( obj quot pred pred-ret -- obj )
- ! quot: ( obj -- obj' )
- ! pred: ( obj -- <=> )
+: (while-changes) ( obj quot: ( obj -- obj' ) pred: ( obj -- <=> ) pred-ret -- obj )
[ [ dup slip ] dip pick over call ] dip dupd =
[ 3drop ] [ (while-changes) ] if ; inline recursive
+warning+ (inference-error) ; inline
M: inference-error error.
- [ "In word: " write word>> . ] [ error>> error. ] bi ;
+ [ word>> [ "In word: " write . ] when* ] [ error>> error. ] bi ;
TUPLE: literal-expected ;
"The recursive word " write
word>> pprint
" calls itself with a different set of quotation parameters than were input" print ;
+
+TUPLE: unknown-primitive-error ;
+
+M: unknown-primitive-error error.
+ drop
+ "Cannot determine stack effect statically" print ;
{ \ load-locals [ infer-load-locals ] }
{ \ get-local [ infer-get-local ] }
{ \ drop-locals [ infer-drop-locals ] }
- { \ do-primitive [ \ do-primitive cannot-infer-effect ] }
+ { \ do-primitive [ unknown-primitive-error inference-warning ] }
{ \ alien-invoke [ infer-alien-invoke ] }
{ \ alien-indirect [ infer-alien-indirect ] }
{ \ alien-callback [ infer-alien-callback ] }
namespaces stack-checker.recursive-state.tree ;
IN: stack-checker.recursive-state
-TUPLE: recursive-state words word quotations inline-words ;
-
-C: <recursive-state> recursive-state
+TUPLE: recursive-state word words quotations inline-words ;
: prepare-recursive-state ( word rstate -- rstate )
swap >>word
dup "A" throw [ bogus-error ] [ drop ] if ; inline recursive
[ bogus-error ] must-infer
+
+[ [ clear ] infer. ] [ inference-error? ] must-fail-with
--- /dev/null
+Doug Coleman
--- /dev/null
+USING: kernel state-tables tools.test ;
+IN: state-tables.tests
+
+: test-table
+ <table>
+ "a" "c" "z" <entry> over set-entry
+ "a" "o" "y" <entry> over set-entry
+ "a" "l" "x" <entry> over set-entry
+ "b" "o" "y" <entry> over set-entry
+ "b" "l" "x" <entry> over set-entry
+ "b" "s" "u" <entry> over set-entry ;
+
+[
+ T{
+ table
+ f
+ H{
+ { "a" H{ { "l" "x" } { "c" "z" } { "o" "y" } } }
+ { "b" H{ { "l" "x" } { "s" "u" } { "o" "y" } } }
+ }
+ H{ { "l" t } { "s" t } { "c" t } { "o" t } }
+ f
+ H{ }
+ }
+] [ test-table ] unit-test
+
+[ "x" t ] [ "a" "l" test-table get-entry ] unit-test
+[ "har" t ] [
+ "a" "z" "har" <entry> test-table [ set-entry ] keep
+ >r "a" "z" r> get-entry
+] unit-test
+
+: vector-test-table
+ <vector-table>
+ "a" "c" "z" <entry> over add-entry
+ "a" "c" "r" <entry> over add-entry
+ "a" "o" "y" <entry> over add-entry
+ "a" "l" "x" <entry> over add-entry
+ "b" "o" "y" <entry> over add-entry
+ "b" "l" "x" <entry> over add-entry
+ "b" "s" "u" <entry> over add-entry ;
+
+[
+T{ vector-table f
+ H{
+ { "a"
+ H{ { "l" "x" } { "c" V{ "z" "r" } } { "o" "y" } } }
+ { "b"
+ H{ { "l" "x" } { "s" "u" } { "o" "y" } } }
+ }
+ H{ { "l" t } { "s" t } { "c" t } { "o" t } }
+ f
+ H{ }
+}
+] [ vector-test-table ] unit-test
+
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel namespaces make sequences vectors assocs accessors ;
+IN: state-tables
+
+TUPLE: table rows columns start-state final-states ;
+TUPLE: entry row-key column-key value ;
+
+GENERIC: add-entry ( entry table -- )
+
+: make-table ( class -- obj )
+ new
+ H{ } clone >>rows
+ H{ } clone >>columns
+ H{ } clone >>final-states ;
+
+: <table> ( -- obj )
+ table make-table ;
+
+C: <entry> entry
+
+: (add-row) ( row-key table -- row )
+ 2dup rows>> at* [
+ 2nip
+ ] [
+ drop H{ } clone [ -rot rows>> set-at ] keep
+ ] if ;
+
+: add-row ( row-key table -- )
+ (add-row) drop ;
+
+: add-column ( column-key table -- )
+ t -rot columns>> set-at ;
+
+: set-row ( row row-key table -- )
+ rows>> set-at ;
+
+: lookup-row ( row-key table -- row/f ? )
+ rows>> at* ;
+
+: row-exists? ( row-key table -- ? )
+ lookup-row nip ;
+
+: lookup-column ( column-key table -- column/f ? )
+ columns>> at* ;
+
+: column-exists? ( column-key table -- ? )
+ lookup-column nip ;
+
+ERROR: no-row key ;
+ERROR: no-column key ;
+
+: get-row ( row-key table -- row )
+ dupd lookup-row [
+ nip
+ ] [
+ drop no-row
+ ] if ;
+
+: get-column ( column-key table -- column )
+ dupd lookup-column [
+ nip
+ ] [
+ drop no-column
+ ] if ;
+
+: get-entry ( row-key column-key table -- obj ? )
+ swapd lookup-row [
+ at*
+ ] [
+ 2drop f f
+ ] if ;
+
+: (set-entry) ( entry table -- value column-key row )
+ [ >r column-key>> r> add-column ] 2keep
+ dupd >r row-key>> r> (add-row)
+ >r [ value>> ] keep column-key>> r> ;
+
+: set-entry ( entry table -- )
+ (set-entry) set-at ;
+
+: delete-entry ( entry table -- )
+ >r [ column-key>> ] [ row-key>> ] bi r>
+ lookup-row [ delete-at ] [ 2drop ] if ;
+
+: swap-rows ( row-key1 row-key2 table -- )
+ [ tuck get-row >r get-row r> ] 3keep
+ >r >r rot r> r> [ set-row ] keep set-row ;
+
+: member?* ( obj obj -- bool )
+ 2dup = [ 2drop t ] [ member? ] if ;
+
+: find-by-column ( column-key data table -- seq )
+ swapd 2dup lookup-column 2drop
+ [
+ rows>> [
+ pick swap at* [
+ >r pick r> member?* [ , ] [ drop ] if
+ ] [
+ 2drop
+ ] if
+ ] assoc-each
+ ] { } make 2nip ;
+
+
+TUPLE: vector-table < table ;
+: <vector-table> ( -- obj )
+ vector-table make-table ;
+
+: add-hash-vector ( value key hash -- )
+ 2dup at* [
+ dup vector? [
+ 2nip push
+ ] [
+ V{ } clone [ push ] keep
+ -rot >r >r [ push ] keep r> r> set-at
+ ] if
+ ] [
+ drop set-at
+ ] if ;
+
+M: vector-table add-entry ( entry table -- )
+ (set-entry) add-hash-vector ;
QUALIFIED: bootstrap.stage2
QUALIFIED: classes
QUALIFIED: command-line
-QUALIFIED: compiler.errors.private
+QUALIFIED: compiler.errors
QUALIFIED: continuations
QUALIFIED: definitions
QUALIFIED: init
strip-debugger? [
{
- compiler.errors.private:compiler-errors
+ compiler.errors:compiler-errors
continuations:thread-error-hook
} %
] when
unportable
-windows
tools
:: (draw-string) ( open-font sprites string loc -- )
GL_TEXTURE_2D [
loc [
- -0.5 0.5 0.0 glTranslated
string open-font string char-widths scan-sums [
[ open-font sprites ] 2dip draw-char
] 2each
: checkmark-points ( dim -- points )
{
- [ { 0 0 } v* { 0 1 } v+ ]
- [ { 1 1 } v* { 0 1 } v+ ]
+ [ { 0 0 } v* ]
+ [ { 1 1 } v* ]
[ { 0 1 } v* ]
[ { 1 0 } v* ]
} cleave 4array ;
: scroll>caret ( editor -- )
dup graft-state>> second [
- dup caret-loc over caret-dim { 1 0 } v+ <rect>
+ dup caret-loc over caret-dim <rect>
over scroll>rect
] when drop ;
grid-dim get spin set-axis ;
: draw-grid-lines ( gaps orientation -- )
- grid get rot grid-positions grid get rect-dim suffix [
- grid-line-from/to gl-line
- ] with each ;
+ [ grid get swap grid-positions grid get rect-dim suffix ] dip
+ [ [ v- ] curry map ] keep
+ [ swap grid-line-from/to gl-line ] curry each ;
M: grid-lines draw-boundary
color>> gl-color [
dup grid set
dup rect-dim half-gap v- grid-dim set
compute-grid
- { 0 1 } draw-grid-lines
- { 1 0 } draw-grid-lines
+ [ { 1 0 } draw-grid-lines ]
+ [ { 0 1 } draw-grid-lines ]
+ bi*
] with-scope ;
[ rect-intersect ] keep
dim>> dup { 0 1 } v* viewport-translation set
{ 0 0 } over gl-viewport
- -0.5 swap first2 [ 0.5 - ] [ 0.5 + ] bi* 0.5 gluOrtho2D
+ 0 swap first2 0 gluOrtho2D
clip set
do-clip ;
listener-gadget "toolbar" f {
{ f restart-listener }
- { T{ key-down f f "CLEAR" } clear-output }
- { T{ key-down f { C+ } "CLEAR" } clear-stack }
+ { T{ key-down f { A+ } "c" } clear-output }
+ { T{ key-down f { A+ } "C" } clear-stack }
{ T{ key-down f { C+ } "d" } com-end }
{ T{ key-down f f "F1" } listener-help }
} define-command-map
: all-groups ( -- seq )
[ getgrent dup ] [ group-struct>group ] [ drop ] produce ;
+: <group-cache> ( -- assoc )
+ all-groups [ [ id>> ] keep ] H{ } map>assoc ;
+
: with-group-cache ( quot -- )
- all-groups [ [ id>> ] keep ] H{ } map>assoc
- group-cache rot with-variable ; inline
+ [ <group-cache> group-cache ] dip with-variable ; inline
: real-group-id ( -- id )
getgid ; inline
SYMBOL: user-cache
+: <user-cache> ( -- assoc )
+ all-users [ [ uid>> ] keep ] H{ } map>assoc ;
+
: with-user-cache ( quot -- )
- all-users [ [ uid>> ] keep ] H{ } map>assoc
- user-cache rot with-variable ; inline
+ [ <user-cache> user-cache ] dip with-variable ; inline
GENERIC: user-passwd ( obj -- passwd )
[ "4561_2612_1234_5467" v-credit-card ] must-fail
[ "4561-2621-1234-5467" v-credit-card ] must-fail
+
+[ t ] [ "http://double.co.nz/w?v=foo" dup v-url = ] unit-test
v-regexp ;
: v-url ( str -- str )
- "URL"
- R' (ftp|http|https)://(\w+:?\w*@)?(\S+)(:[0-9]+)?(/|/([\w#!:.?+=&%@!\-/]))?'
- v-regexp ;
+ "URL" R' (ftp|http|https)://\S+' v-regexp ;
: v-captcha ( str -- str )
dup empty? [ "must remain blank" throw ] unless ;
unportable
-windows
-com
bindings
unportable
-windows
-com
bindings
unportable
-windows
-com
bindings
unportable
-windows
bindings
: THREAD_PRIORITY_TIME_CRITICAL 15 ; inline
C-STRUCT: OVERLAPPED
- { "int" "internal" }
- { "int" "internal-high" }
- { "int" "offset" }
- { "int" "offset-high" }
- { "void*" "event" } ;
+ { "UINT_PTR" "internal" }
+ { "UINT_PTR" "internal-high" }
+ { "DWORD" "offset" }
+ { "DWORD" "offset-high" }
+ { "HANDLE" "event" } ;
C-STRUCT: SYSTEMTIME
{ "WORD" "wYear" }
unportable
-windows
bindings
TYPEDEF: void* LPCVOID
TYPEDEF: float FLOAT
-TYPEDEF: short HALF_PTR
-TYPEDEF: ushort UHALF_PTR
-TYPEDEF: int INT_PTR
-TYPEDEF: uint UINT_PTR
+
+TYPEDEF: intptr_t HALF_PTR
+TYPEDEF: intptr_t UHALF_PTR
+TYPEDEF: intptr_t INT_PTR
+TYPEDEF: intptr_t UINT_PTR
TYPEDEF: int LONG_PTR
TYPEDEF: ulong ULONG_PTR
IN: compiler.errors
USING: help.markup help.syntax vocabs.loader words io
-quotations compiler.errors.private ;
+quotations ;
ARTICLE: "compiler-errors" "Compiler warnings and errors"
"The compiler saves various notifications in a global variable:"
GENERIC# compiler-error. 1 ( error word -- )
-<PRIVATE
-
SYMBOL: compiler-errors
SYMBOL: with-compiler-errors?
"semantic warnings" +warning+ "warnings" (compiler-report)
"linkage errors" +linkage+ "linkage" (compiler-report) ;
-PRIVATE>
-
: :errors ( -- ) +error+ compiler-errors. ;
: :warnings ( -- ) +warning+ compiler-errors. ;
! Make sure we use correct to_c_string form when writing
[ ] [ "\0" write ] unit-test
+[ ] [
+ "It seems Jobs has lost his grasp on reality again.\n"
+ "separator-test.txt" temp-file latin1 set-file-contents
+] unit-test
+
[
{
{ "It seems " CHAR: J }
}
] [
[
- "resource:core/io/test/separator-test.txt"
+ "separator-test.txt" temp-file
latin1 <file-reader> [
"J" read-until 2array ,
"i" read-until 2array ,
: map-last ( seq quot -- seq )
>r dup length <reversed> [ zero? ] r> compose 2map ; inline
+PRIVATE>
+
: format-table ( table -- seq )
flip [ format-column ] map-last
flip [ " " join ] map ;
-PRIVATE>
-
M: growable dispose drop ;
M: growable stream-write1 push ;
+++ /dev/null
-It seems Jobs has lost his grasp on reality again.
{ { $snippet "extra" } " - additional contributed libraries." }
{ { $snippet "work" } " - a root for vocabularies which are not intended to be contributed back to Factor." }
}
-"Your own vocabularies should go into " { $snippet "extra" } " or " { $snippet "work" } ", depending on whether or not you intend to contribute them back to the Factor project. If you wish to work on vocabularies outside of the Factor source directory, create a " { $snippet "~/.factor-rc" } " file like the following,"
+"Your own vocabularies should go into " { $snippet "extra" } " or " { $snippet "work" } ", depending on whether or not you intend to contribute them back to the Factor project. If you wish to work on vocabularies outside of the Factor source directory, create a " { $link "factor-boot-rc" } " file like the following:"
{ $code
"USING: namespaces sequences vocabs.loader ;"
"\"/home/jane/sources/\" vocab-roots get push"
-! Unit tests for vocabs.loader vocabulary
IN: vocabs.loader.tests
USING: vocabs.loader tools.test continuations vocabs math
kernel arrays sequences namespaces io.streams.string
parser source-files words assocs classes.tuple definitions
-debugger compiler.units tools.vocabs accessors eval ;
+debugger compiler.units tools.vocabs accessors eval
+combinators ;
! This vocab should not exist, but just in case...
[ ] [
[ "xabbabbja" forget-vocab ] with-compilation-unit
forget-junk
+
+[ ] [ [ "vocabs.loader.test.e" forget-vocab ] with-compilation-unit ] unit-test
+
+[ "vocabs.loader.test.e" require ]
+[ relative-overflow? ] must-fail-with
f over set-vocab-source-loaded?
[ vocab-source-path [ parse-file ] [ [ ] ] if* ] keep
t swap set-vocab-source-loaded?
- [ % ] [ call ] if-bootstrapping ;
+ [ % ] [ assert-depth ] if-bootstrapping ;
: load-docs ( vocab -- vocab )
load-help? get [
--- /dev/null
+unportable
: init-rule ( -- ) 8 <hashtable> >rule ;
: rule-keys ( -- array )
-{ { 1 1 1 }
- { 1 1 0 }
- { 1 0 1 }
- { 1 0 0 }
- { 0 1 1 }
- { 0 1 0 }
- { 0 0 1 }
- { 0 0 0 } } ;
+ { { 1 1 1 }
+ { 1 1 0 }
+ { 1 0 1 }
+ { 1 0 0 }
+ { 0 1 1 }
+ { 0 1 0 }
+ { 0 0 1 }
+ { 0 0 0 } } ;
: rule-values ( n -- seq ) >bin 8 CHAR: 0 pad-left string>digits ;
: set-rule ( n -- )
-dup >rule-number rule-values rule-keys [ rule> set-at ] 2each ;
+ dup >rule-number rule-values rule-keys [ rule> set-at ] 2each ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! step-capped-line
: cap-line ( line -- 0-line-0 ) { 0 } prepend { 0 } append ;
: wrap-line ( a-line-z -- za-line-za )
-dup peek 1array swap dup first 1array append append ;
+ dup peek 1array swap dup first 1array append append ;
: step-line ( line -- new-line ) 3 <clumps> [ pattern>state ] map ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: interesting ( -- seq )
-{ 18 22 26 30 41 45 54 60 73 75 82 86 89 90 97 101 102 105 106 107 109
- 110 120 121 122 124 126 129 137 146 147 149 150 151 153 154 161 165 } ;
+ { 18 22 26 30 41 45 54 60 73 75 82 86 89 90 97 101 102 105 106 107 109
+ 110 120 121 122 124 126 129 137 146 147 149 150 151 153 154 161 165 } ;
: mild ( -- seq ) { 6 9 11 57 62 74 118 } ;
VAR: last-line
: run-rule ( -- )
-last-line> height> [ drop step-capped-line dup ] map >bitmap >last-line ;
+ last-line> height> [ drop step-capped-line dup ] map >bitmap >last-line ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Call a 'model' quotation with the current 'view'.
: with-view ( quot -- )
-slate> rect-dim first >width
-slate> rect-dim second >height
-call
-slate> relayout-1 ;
+ slate> rect-dim first >width
+ slate> rect-dim second >height
+ call
+ slate> relayout-1 ;
! Create a quotation that is appropriate for buttons and gesture handler.
USING: benchmark.regex-dna io io.files io.encodings.ascii
-io.streams.string kernel tools.test ;
+io.streams.string kernel tools.test splitting ;
IN: benchmark.regex-dna.tests
[ t ] [
"resource:extra/benchmark/regex-dna/regex-dna-test-in.txt"
- [ regex-dna ] with-string-writer
+ [ regex-dna ] with-string-writer <string-reader> lines
"resource:extra/benchmark/regex-dna/regex-dna-test-out.txt"
- ascii file-contents =
+ ascii file-lines =
] unit-test
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: init-variables ( -- )
-1.0 >cohesion-weight
-1.0 >alignment-weight
-1.0 >separation-weight
+ 1.0 >cohesion-weight
+ 1.0 >alignment-weight
+ 1.0 >separation-weight
-75 >cohesion-radius
-50 >alignment-radius
-25 >separation-radius
+ 75 >cohesion-radius
+ 50 >alignment-radius
+ 25 >separation-radius
-180 >cohesion-view-angle
-180 >alignment-view-angle
-180 >separation-view-angle
+ 180 >cohesion-view-angle
+ 180 >alignment-view-angle
+ 180 >separation-view-angle
-10 >time-slice ;
+ 10 >time-slice ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! random-boid and random-boids
: constrain ( n a b -- n ) rot min max ;
: angle-between ( vec vec -- angle )
-2dup v. -rot norm swap norm * / -1 1 constrain acos rad>deg ;
+ 2dup v. -rot norm swap norm * / -1 1 constrain acos rad>deg ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: relative-position ( self other -- v ) swap [ pos>> ] bi@ v- ;
: relative-angle ( self other -- angle )
-over vel>> -rot relative-position angle-between ;
+ over vel>> -rot relative-position angle-between ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: above? ( n a b -- ? ) nip > ;
: wrap ( n a b -- n )
-{ { [ 3dup below? ]
- [ 2nip ] }
- { [ 3dup above? ]
- [ drop nip ] }
- { [ t ]
- [ 2drop ] } }
-cond ;
+ {
+ { [ 3dup below? ] [ 2nip ] }
+ { [ 3dup above? ] [ drop nip ] }
+ { [ t ] [ 2drop ] }
+ }
+ cond ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
USING: kernel namespaces math opengl.gl opengl.glu ui ui.gadgets.slate
- mortar random-weighted cfdg ;
+ random-weighted cfdg ;
IN: cfdg.models.game1-turn6
USING: kernel namespaces math opengl.gl opengl.glu ui ui.gadgets.slate
- mortar random-weighted cfdg ;
+ random-weighted cfdg ;
IN: cfdg.models.sierpinski
: changelog ( -- authors )
image parent-directory [
- "git
-log --pretty=format:%an" ascii <process-reader> lines
+ "git
log --pretty=format:%an" ascii <process-reader> lines
] with-directory ;
: patch-counts ( authors -- assoc )
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-USING: kernel combinators sequences math math.functions math.vectors mortar
- slot-accessors x x.widgets.wm.root x.widgets.wm.frame sequences.lib ;
-IN: factory.commands
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: up-till-frame ( window -- wm-frame )
-{ { [ dup <wm-frame> is? ]
- [ ] }
- { [ dup $dpy $default-root $id over $id = ]
- [ drop f ] }
- { [ t ]
- [ <- parent up-till-frame ] } } cond ;
-
-: pointer-window ( -- window ) dpy> <- pointer-window ;
-
-: pointer-frame ( -- wm-frame )
-pointer-window up-till-frame dup <wm-frame> is? [ ] [ drop f ] if ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: maximize ( -- ) pointer-frame wm-frame-maximize drop ;
-
-: minimize ( -- ) pointer-frame <- unmap drop ;
-
-: maximize-vertical ( -- ) pointer-frame wm-frame-maximize-vertical drop ;
-
-: restore ( -- ) pointer-frame <- restore-state drop ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-
-
-: tile-master ( -- )
-
-wm-root>
- <- children
- [ <- mapped? ] filter
- [ check-window-table ] map
- reverse
-
-unclip
- { 0 0 } <-- move
- wm-root> <- size { 1/2 1 } v*
- [ floor ] map <-- resize
- <- adjust-child
-drop
-
-dup empty? [ drop ] [
-
-wm-root> <- width 2 / floor [ <-- set-width ] curry map
-wm-root> <- height over length / floor [ <-- set-height ] curry map
-
-wm-root> <- width 2 / floor [ <-- set-x ] curry map
-
-wm-root> <- height over length / over length [ * floor ] map-with
-[ <-- set-y <- adjust-child ] 2map
-
-drop
-
-] if ;
-
-! : tile-master ( -- )
-
-! wm-root>
-! <- children
-! [ <- mapped? ] filter
-! [ check-window-table ] map
-! reverse
-
-! { { [ dup empty? ] [ drop ] }
-! { [ dup length 1 = ] [ drop maximize ] }
-! { [ t ] [ tile-master* ] }
+++ /dev/null
-! -*-factor-*-
-
-USING: kernel unix vars mortar mortar.sugar slot-accessors
- x.widgets.wm.menu x.widgets.wm.unmapped-frames-menu
- factory.commands factory.load ;
-
-IN: factory
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! Helper words
-
-: new-wm-menu ( -- menu ) <wm-menu> new* 1 <-- set-border-width ;
-
-: shrink-wrap ( menu -- ) dup <- calc-size <-- resize drop ;
-
-: set-menu-items ( items menu -- ) swap >>items shrink-wrap ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-VAR: apps-menu
-
-apps-menu> not [ new-wm-menu >apps-menu ] when
-
-{ { "Emacs" [ "emacs &" system drop ] }
- { "KMail" [ "kmail &" system drop ] }
- { "Akregator" [ "akregator &" system drop ] }
- { "Amarok" [ "amarok &" system drop ] }
- { "K3b" [ "k3b &" system drop ] }
- { "xchat" [ "xchat &" system drop ] }
- { "Nautilus" [ "nautilus --no-desktop &" system drop ] }
- { "synaptic" [ "gksudo synaptic &" system drop ] }
- { "Volume control" [ "gnome-volume-control &" system drop ] }
- { "Azureus" [ "~/azureus/azureus &" system drop ] }
- { "Xephyr" [ "Xephyr -host-cursor :1 &" system drop ] }
- { "Stop Xephyr" [ "pkill Xephyr &" system drop ] }
- { "Stop Firefox" [ "pkill firefox &" system drop ] }
-} apps-menu> set-menu-items
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-VAR: emacs-menu
-
-emacs-menu> not [ new-wm-menu >emacs-menu ] when
-
-{ { "Start Emacs" [ "emacs &" system drop ] }
- { "Small" [ "emacsclient -e '(make-small-frame-command)' &" system drop ] }
- { "Large" [ "emacsclient -e '(make-frame-command)' &" system drop ] }
- { "Full" [ "emacsclient -e '(make-full-frame-command)' &" system drop ] }
- { "Gnus" [ "emacsclient -e '(gnus-other-frame)' &" system drop ] }
- { "Factor" [ "emacsclient -e '(run-factor-other-frame)' &" system drop ] }
-} emacs-menu> set-menu-items
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-VAR: mail-menu
-
-mail-menu> not [ new-wm-menu >mail-menu ] when
-
-{ { "Kmail" [ "kmail &" system drop ] }
- { "compose" [ "kmail --composer &" system drop ] }
- { "slava" [ "kmail slava@factorcode.org &" system drop ] }
- { "erg" [ "kmail doug.coleman@gmail.com &" system drop ] }
- { "doublec" [ "kmail chris.double@double.co.nz &" system drop ] }
- { "yuuki" [ "kmail matthew.willis@mac.com &" system drop ] }
-} mail-menu> set-menu-items
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-VAR: factor-menu
-
-factor-menu> not [ new-wm-menu >factor-menu ] when
-
-{ { "Factor" [ "cd /scratch/repos/Factor ; ./factor &" system drop ] }
- { "Factor (tty)"
- [ "cd /scratch/repos/Factor ; xterm -e ./factor -run=listener &"
- system drop ] }
- { "Terminal : repos/Factor"
- [ "cd /scratch/repos/Factor ; xterm &" system drop ] }
- { "darcs whatsnew"
- [ "cd /scratch/repos/Factor ; xterm -e 'darcs whatsnew | less' &"
- system drop ] }
- { "darcs pull"
- [ "cd /scratch/repos/Factor ; xterm -e 'darcs pull http://factorcode.org/repos' &" system drop ] }
- { "darcs push"
- [ "cd /scratch/repos/Factor ; xterm -e 'darcs push dharmatech@onigirihouse.com:doc-root/repos' &" system drop ] }
-} factor-menu> set-menu-items
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-VAR: factory-menu
-
-factory-menu> not [ new-wm-menu >factory-menu ] when
-
-{ { "Maximize" [ maximize ] }
- { "Maximize Vertical" [ maximize-vertical ] }
- { "Restore" [ restore ] }
- { "Hide" [ minimize ] }
- { "Tile Master" [ tile-master ] }
-}
-
-factory-menu> set-menu-items
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! VAR: root-menu
-
-{ { "xterm" [ "urxvt -bd grey +sb &" system drop ] }
- { "Firefox" [ "firefox &" system drop ] }
- { "xclock" [ "xclock &" system drop ] }
- { "Apps >" [ apps-menu> <- popup ] }
- { "Factor >" [ factor-menu> <- popup ] }
- { "Unmapped frames >" [ unmapped-frames-menu> <- popup ] }
- { "Emacs >" [ emacs-menu> <- popup ] }
- { "Mail >" [ mail-menu> <- popup ] }
- { "onigirihouse" [ "xterm -e 'ssh dharmatech@onigirihouse.com' &"
- system drop ] }
- { "Edit menus" [ edit-factory-menus ] }
- { "Reload menus" [ load-factory-menus ] }
- { "Factory >" [ factory-menu> <- popup ] }
-} root-menu> set-menu-items
-
+++ /dev/null
-! -*-factor-*-
-
-USING: kernel mortar x
- x.widgets.wm.root
- x.widgets.wm.workspace
- x.widgets.wm.unmapped-frames-menu
- factory.load
- tty-server ;
-
-IN: factory
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-create-root-menu
-create-unmapped-frames-menu
-load-factory-menus
-6 setup-workspaces
-
-wm-root>
- no-modifiers "F12" [ root-menu> <- popup ] <---- set-key-action
- control-alt "LEFT" [ prev-workspace ] <---- set-key-action
- control-alt "RIGHT" [ next-workspace ] <---- set-key-action
- alt "TAB" [ circulate-focus ] <---- set-key-action
-drop
-
-9010 tty-server
+++ /dev/null
-
-USING: kernel parser io io.files namespaces sequences editors threads vars
- mortar mortar.sugar slot-accessors
- x
- x.widgets.wm.root
- x.widgets.wm.frame
- x.widgets.wm.menu
- factory.load
- factory.commands ;
-
-IN: factory
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: manage-windows ( -- )
-dpy get $default-root <- children [ <- mapped? ] filter
-[ $id <wm-frame> new* drop ] each ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-VAR: root-menu
-
-: create-root-menu ( -- ) <wm-menu> new* 1 <-- set-border-width >root-menu ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: start-factory ( display-string -- )
-<display> new* >dpy
-install-default-error-handler
-create-wm-root
-init-atoms
-manage-windows
-load-factory-rc ;
-
-: factory ( -- ) f start-factory stop ;
-
-MAIN: factory
\ No newline at end of file
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-
-USING: kernel io.files parser editors sequences ;
-
-IN: factory.load
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: file-or ( file file -- file ) over exists? [ drop ] [ nip ] if ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: personal-factory-rc ( -- path ) home "/.factory-rc" append ;
-
-: system-factory-rc ( -- path ) "extra/factory/factory-rc" resource-path ;
-
-: factory-rc ( -- path ) personal-factory-rc system-factory-rc file-or ;
-
-: load-factory-rc ( -- ) factory-rc run-file ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: personal-factory-menus ( -- path ) home "/.factory-menus" append ;
-
-: system-factory-menus ( -- path )
-"extra/factory/factory-menus" resource-path ;
-
-: factory-menus ( -- path )
-personal-factory-menus system-factory-menus file-or ;
-
-: load-factory-menus ( -- ) factory-menus run-file ;
-
-: edit-factory-menus ( -- ) factory-menus 0 edit-location ;
+++ /dev/null
-Window manager for the X Window System
+++ /dev/null
-applications
unicode.case splitting assocs classes io.servers.connection
destructors calendar io.timeouts io.streams.duplex threads
continuations math concurrency.promises byte-arrays
-io.backend sequences.lib tools.hexdump io.files.listing ;
+io.backend sequences.lib tools.hexdump io.files.listing
+io.streams.string ;
IN: ftp.server
-TUPLE: ftp-client url mode state command-promise ;
+TUPLE: ftp-client url mode state command-promise user password ;
: <ftp-client> ( url -- ftp-client )
ftp-client new
150 "Here comes the directory listing." server-response ;
: finish-directory ( -- )
- 226 "Opening " server-response ;
+ 226 "Directory send OK." server-response ;
GENERIC: service-command ( stream obj -- )
M: ftp-list service-command ( stream obj -- )
drop
- start-directory
- [
+ start-directory [
utf8 encode-output
- directory. [ ftp-send ] each
+ [ current-directory get directory. ] with-string-writer string-lines
+ harvest [ ftp-send ] each
] with-output-stream
finish-directory ;
--- /dev/null
+Slava Pestov
--- /dev/null
+Slides from a talk at Galois by Slava Pestov, October 2008
unportable
-input
-gamepads
-joysticks
-windows
+games
unportable
-gamepads
-joysticks
-mac
-input
+games
-gamepads
-joysticks
-input
+games
-joysticks
-gamepads
-input
+games
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-
-USING: sequences mortar slot-accessors ;
-
-IN: geom.dim
-
-SYMBOL: <dim>
-
-<dim> { "dim" } accessors define-independent-class
-
-<dim> {
-
-"width" !( dim -- width ) [ $dim first ]
-
-"height" !( dim -- second ) [ $dim second ]
-
-} add-methods
\ No newline at end of file
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-
-USING: kernel arrays sequences math.vectors mortar slot-accessors ;
-
-IN: geom.pos
-
-SYMBOL: <pos>
-
-<pos> { "pos" } accessors define-independent-class
-
-<pos> {
-
-"x" !( pos -- x ) [ $pos first ]
-
-"y" !( pos -- y ) [ $pos second ]
-
-"set-x" !( pos x -- pos ) [ 0 pick $pos set-nth ]
-
-"set-y" !( pos y -- pos ) [ 1 pick $pos set-nth ]
-
-"distance" !( pos pos -- distance ) [ $pos swap $pos v- norm ]
-
-"move-by" !( pos offset -- pos ) [ over $pos v+ >>pos ]
-
-"move-by-x" !( pos x-offset -- pos ) [ 0 2array <-- move-by ]
-
-"move-by-y" !( pos y-offset -- pos ) [ 0 swap 2array <-- move-by ]
-
-} add-methods
\ No newline at end of file
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-
-USING: kernel namespaces arrays sequences math.vectors
- mortar slot-accessors geom.pos geom.dim ;
-
-IN: geom.rect
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-USE: math
-
-: v+y ( pos y -- pos ) 0 swap 2array v+ ;
-
-: v-y ( pos y -- pos ) 0 swap 2array v- ;
-
-: v+x ( pos x -- pos ) 0 2array v+ ;
-
-: v-x ( pos x -- pos ) 0 2array v- ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-SYMBOL: <rect>
-
-<rect>
- <pos> class-slots <dim> class-slots append
- <pos> class-methods <dim> class-methods append { H{ } } append
- { H{ } }
-4array <rect> set-global
-
-! { 0 0 } { 0 0 } <rect> new
-
-<rect> {
-
-"top-left" !( rect -- point ) [ $pos ]
-
-"top-right" !( rect -- point ) [ dup $pos swap <- width 1- v+x ]
-
-"bottom-left" !( rect -- point ) [ dup $pos swap <- height 1- v+y ]
-
-"bottom-right" !( rect -- point ) [ dup $pos swap $dim { 1 1 } v- v+ ]
-
-} add-methods
\ No newline at end of file
--- /dev/null
+Slava Pestov
--- /dev/null
+Slides from Google Tech Talk by Slava Pestov, October 2008
! Copyright (C) 2007 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien arrays byte-arrays combinators summary
-io.backend graphics.viewer io io.binary io.files kernel libc
-math math.functions namespaces opengl opengl.gl prettyprint
-sequences strings ui ui.gadgets.panes io.encodings.binary
-accessors grouping ;
+USING: alien arrays byte-arrays combinators summary io.backend
+graphics.viewer io io.binary io.files kernel libc math
+math.functions math.bitwise namespaces opengl opengl.gl
+prettyprint sequences strings ui ui.gadgets.panes
+io.encodings.binary accessors grouping ;
IN: graphics.bitmap
! Currently can only handle 24bit bitmaps.
: parse-bitmap-header ( bitmap -- )
4 read le> >>header-length
- 4 read le> >>width
- 4 read le> >>height
+ 4 read signed-le> >>width
+ 4 read signed-le> >>height
2 read le> >>planes
2 read le> >>bit-count
4 read le> >>compression
: make-int-array ( seq -- byte-array )
[ <int> ] map concat ;
-: (sysctl-query) ( name namelen oldp oldlenp -- oldp error/f )
- over >r f 0 sysctl io-error r> ;
+: (sysctl-query) ( name namelen oldp oldlenp -- oldp )
+ over [ f 0 sysctl io-error ] dip ;
: sysctl-query ( seq n -- byte-array )
- >r [ make-int-array ] [ length ] bi r>
+ [ [ make-int-array ] [ length ] bi ] dip
[ <byte-array> ] [ <uint> ] bi (sysctl-query) ;
: sysctl-query-string ( seq -- n )
: processor-architecture ( -- n )
system-info SYSTEM_INFO-dwOemId HEX: ffff0000 bitand ;
-: os-version
+: os-version ( -- os-version )
"OSVERSIONINFO" <c-object>
"OSVERSIONINFO" heap-size over set-OSVERSIONINFO-dwOSVersionInfoSize
[ GetVersionEx ] keep swap zero? [ win32-error ] when ;
{
{ [ os wince? ] [ "hardware-info.windows.ce" ] }
{ [ os winnt? ] [ "hardware-info.windows.nt" ] }
-} cond [ require ] when* >>
+} cond require >>
[ [ [ blank? ] trim ] change-text ] when
] map ;
-: find-by-id ( vector id -- vector' )
+: find-by-id ( vector id -- vector' elt/f )
'[ attributes>> "id" at _ = ] find ;
-: find-by-class ( vector id -- vector' )
+: find-by-class ( vector id -- vector' elt/f )
'[ attributes>> "class" at _ = ] find ;
-: find-by-name ( vector string -- vector )
+: find-by-name ( vector string -- vector elt/f )
>lower '[ name>> _ = ] find ;
: find-by-id-between ( vector string -- vector' )
[ attributes>> "id" swap at _ = ] bi and
] dupd find find-between* ;
-: find-by-attribute-key ( vector key -- vector' )
+: find-by-attribute-key ( vector key -- vector' elt/? )
>lower
[ attributes>> at _ = ] filter sift ;
-mac
bindings
-system
+unportable
-mac
bindings
-system
+unportable
-gamepads
-joysticks
+games
! See http://factorcode.org/license.txt for BSD license.
USING: io.files io.launcher io.encodings.utf8 prettyprint arrays
calendar namespaces mason.common mason.child
-mason.release mason.report mason.email mason.cleanup ;
+mason.release mason.report mason.email mason.cleanup
+mason.help ;
IN: mason.build
: create-build-dir ( -- )
clone-builds-factor
record-id
build-child
+ upload-help
release
email-report
cleanup ;
IN: mason.child.tests
USING: mason.child mason.config tools.test namespaces ;
-[ { "make" "clean" "winnt-x86-32" } ] [
+[ { "make" "winnt-x86-32" } ] [
[
"winnt" target-os set
"x86.32" target-cpu set
] with-scope
] unit-test
-[ { "make" "clean" "macosx-x86-32" } ] [
+[ { "make" "macosx-x86-32" } ] [
[
"macosx" target-os set
"x86.32" target-cpu set
] with-scope
] unit-test
-[ { "gmake" "clean" "netbsd-ppc" } ] [
+[ { "gmake" "netbsd-ppc" } ] [
[
"netbsd" target-os set
"ppc" target-cpu set
! See http://factorcode.org/license.txt for BSD license.
USING: kernel namespaces make debugger sequences io.files
io.launcher arrays accessors calendar continuations
-combinators.short-circuit mason.common mason.report mason.platform ;
+combinators.short-circuit mason.common mason.report
+mason.platform mason.config http.client ;
IN: mason.child
: make-cmd ( -- args )
- [ gnu-make , "clean" , platform , ] { } make ;
+ gnu-make platform 2array ;
+
+: download-dlls ( -- )
+ target-os get "winnt" = [
+ "http://factorcode.org/dlls/"
+ target-cpu get "x86.64" = [ "64/" append ] when
+ [ "freetype6.dll" append ]
+ [ "zlib1.dll" append ] bi
+ [ download ] bi@
+ ] when ;
: make-vm ( -- )
"factor" [
+ download-dlls
+
<process>
make-cmd >>command
"../compile-log" >>stdout
[ load-everything-vocabs-file eval-file empty? ]
[ test-all-vocabs-file eval-file empty? ]
[ help-lint-vocabs-file eval-file empty? ]
+ [ compiler-errors-file eval-file empty? ]
} 0&& ;
: build-child ( -- )
: boot-time-file "boot-time" ;
: load-time-file "load-time" ;
+: compiler-errors-file "compiler-errors" ;
: test-time-file "test-time" ;
: help-lint-time-file "help-lint-time" ;
: benchmark-time-file "benchmark-time" ;
help-directory get "/docs.tar.gz" append
upload-safely ;
-: upload-help ( -- )
+: (upload-help) ( -- )
upload-help? get [
make-help-archive
upload-help-archive
] when ;
+
+: upload-help ( -- )
+ status get status-clean eq? [ (upload-help) ] when ;
! See http://factorcode.org/license.txt for BSD license.
USING: kernel namespaces debugger fry io io.files io.sockets
io.encodings.utf8 prettyprint benchmark mason.common
-mason.platform mason.config ;
+mason.platform mason.config sequences ;
IN: mason.report
: time. ( file -- )
nl
- "Did not pass load-everything:" print
- load-everything-vocabs-file cat
- load-everything-errors-file cat
+ load-everything-vocabs-file eval-file [
+ "== Did not pass load-everything:" print .
+ load-everything-errors-file cat
+ ] unless-empty
- "Did not pass test-all:" print
- test-all-vocabs-file cat
- test-all-errors-file cat
+ compiler-errors-file eval-file [
+ "== Vocabularies with compiler errors:" print .
+ ] unless-empty
- "Did not pass help-lint:" print
- help-lint-vocabs-file cat
- help-lint-errors-file cat
+ test-all-vocabs-file eval-file [
+ "== Did not pass test-all:" print .
+ test-all-errors-file cat
+ ] unless-empty
- "Benchmarks:" print
+ help-lint-vocabs-file eval-file [
+ "== Did not pass help-lint:" print .
+ help-lint-errors-file cat
+ ] unless-empty
+
+ "== Benchmarks:" print
benchmarks-file eval-file benchmarks.
] with-report ;
\ No newline at end of file
! See http://factorcode.org/license.txt for BSD license.
USING: kernel namespaces assocs io.files io.encodings.utf8
prettyprint help.lint benchmark tools.time bootstrap.stage2
-tools.test tools.vocabs help.html mason.common ;
+tools.test tools.vocabs help.html mason.common words generic
+accessors compiler.errors sequences sets sorting ;
IN: mason.test
: do-load ( -- )
[ load-everything-errors-file utf8 [ load-failures. ] with-file-writer ]
bi ;
+GENERIC: word-vocabulary ( word -- vocabulary )
+
+M: word word-vocabulary vocabulary>> ;
+
+M: method-body word-vocabulary "method-generic" word-prop word-vocabulary ;
+
+: do-compile-errors ( -- )
+ compiler-errors-file utf8 [
+ +error+ errors-of-type keys
+ [ word-vocabulary ] map
+ prune natural-sort .
+ ] with-file-writer ;
+
: do-tests ( -- )
run-all-tests
[ keys test-all-vocabs-file to-file ]
: do-all ( -- )
".." [
bootstrap-time get boot-time-file to-file
- [ do-load ] benchmark load-time-file to-file
+ [ do-load do-compile-errors ] benchmark load-time-file to-file
[ generate-help ] benchmark html-help-time-file to-file
[ do-tests ] benchmark test-time-file to-file
[ do-help-lint ] benchmark help-lint-time-file to-file
" [ cos ]"
" bi - abs"
"] map minmax"
-
}
}
} ;
{ $subsection derivative }
{ $subsection derivative-func }
{ $subsection (derivative) } ;
+
ABOUT: "derivatives"
--- /dev/null
+USING: help.markup help.syntax math sequences ;
+IN: math.polynomials
+
+ARTICLE: "polynomials" "Polynomials"
+"A polynomial is a vector with the highest powers on the right:"
+{ $code "{ 1 1 0 1 } -> 1 + x + x^3" "{ } -> 0" }
+"Numerous words are defined to help with polynomial arithmetic:"
+{ $subsection p= }
+{ $subsection p+ }
+{ $subsection p- }
+{ $subsection p* }
+{ $subsection p-sq }
+{ $subsection powers }
+{ $subsection n*p }
+{ $subsection p/mod }
+{ $subsection pgcd }
+{ $subsection polyval }
+{ $subsection pdiff }
+{ $subsection pextend-conv }
+{ $subsection ptrim }
+{ $subsection 2ptrim } ;
+
+ABOUT: "polynomials"
+
+HELP: powers
+{ $values { "n" integer } { "x" number } { "seq" sequence } }
+{ $description "Output a sequence having " { $snippet "n" } " elements in the format: " { $snippet "{ 1 x x^2 x^3 ... }" } "." }
+{ $examples { $example "USING: math.polynomials prettyprint ;" "4 2 powers ." "{ 1 2 4 8 }" } } ;
+
+HELP: p=
+{ $values { "p" "a polynomial" } { "q" "a polynomial" } { "?" "a boolean" } }
+{ $description "Tests if two polynomials are equal." }
+{ $examples { $example "USING: math.polynomials prettyprint ;" "{ 0 1 } { 0 1 0 } p= ." "t" } } ;
+
+HELP: ptrim
+{ $values { "p" "a polynomial" } { "p" "a polynomial" } }
+{ $description "Trims excess zeros from a polynomial." }
+{ $examples { $example "USING: math.polynomials prettyprint ;" "{ 0 1 0 0 } ptrim ." "{ 0 1 }" } } ;
+
+HELP: 2ptrim
+{ $values { "p" "a polynomial" } { "q" "a polynomial" } { "p" "a polynomial" } { "q" "a polynomial" } }
+{ $description "Trims excess zeros from two polynomials." }
+{ $examples { $example "USING: kernel math.polynomials prettyprint ;" "{ 0 1 0 0 } { 1 0 0 } 2ptrim [ . ] bi@" "{ 0 1 }\n{ 1 }" } } ;
+
+HELP: p+
+{ $values { "p" "a polynomial" } { "q" "a polynomial" } { "r" "a polynomial" } }
+{ $description "Adds " { $snippet "p" } " and " { $snippet "q" } " component-wise." }
+{ $examples { $example "USING: math.polynomials prettyprint ;" "{ 1 0 1 } { 0 1 } p+ ." "{ 1 1 1 }" } } ;
+
+HELP: p-
+{ $values { "p" "a polynomial" } { "q" "a polynomial" } { "r" "a polynomial" } }
+{ $description "Subtracts " { $snippet "q" } " from " { $snippet "p" } " component-wise." }
+{ $examples { $example "USING: math.polynomials prettyprint ;" "{ 1 1 1 } { 0 1 } p- ." "{ 1 0 1 }" } } ;
+
+HELP: n*p
+{ $values { "n" number } { "p" "a polynomial" } { "n*p" "a polynomial" } }
+{ $description "Multiplies each element of " { $snippet "p" } " by " { $snippet "n" } "." }
+{ $examples { $example "USING: math.polynomials prettyprint ;" "4 { 3 0 1 } n*p ." "{ 12 0 4 }" } } ;
+
+HELP: pextend-conv
+{ $values { "p" "a polynomial" } { "q" "a polynomial" } { "p" "a polynomial" } { "q" "a polynomial" } }
+{ $description "Convulution, extending to " { $snippet "p_m + q_n - 1" } "." }
+{ $examples { $example "USING: kernel math.polynomials prettyprint ;" "{ 1 0 1 } { 0 1 } pextend-conv [ . ] bi@" "V{ 1 0 1 0 }\nV{ 0 1 0 0 }" } } ;
+
+HELP: p*
+{ $values { "p" "a polynomial" } { "q" "a polynomial" } { "r" "a polynomial" } }
+{ $description "Multiplies two polynomials." }
+{ $examples { $example "USING: math.polynomials prettyprint ;" "{ 1 2 3 0 0 0 } { 1 2 0 0 } p* ." "{ 1 4 7 6 0 0 0 0 0 }" } } ;
+
+HELP: p-sq
+{ $values { "p" "a polynomial" } { "p^2" "a polynomial" } }
+{ $description "Squares a polynomial." }
+{ $examples { $example "USING: math.polynomials prettyprint ;" "{ 1 2 0 } p-sq ." "{ 1 4 4 0 0 }" } } ;
+
+HELP: p/mod
+{ $values { "p" "a polynomial" } { "q" "a polynomial" } { "z" "a polynomial" } { "w" "a polynomial" } }
+{ $description "Computes to quotient " { $snippet "z" } " and remainder " { $snippet "w" } " of dividing " { $snippet "p" } " by " { $snippet "q" } "." }
+{ $examples { $example "USING: kernel math.polynomials prettyprint ;" "{ 1 1 1 1 } { 3 1 } p/mod [ . ] bi@" "V{ 7 -2 1 }\nV{ -20 0 0 }" } } ;
+
+HELP: pgcd
+{ $values { "p" "a polynomial" } { "q" "a polynomial" } { "a" "a polynomial" } { "d" "a polynomial" } }
+{ $description "Computes the greatest common divisor " { $snippet "d" } " of " { $snippet "p" } " and " { $snippet "q" } ", and another value " { $snippet "a" } " satisfying:" { $code "a*q = d mod p" } }
+{ $notes "GCD in the case of polynomials is a monic polynomial of the highest possible degree that divides into both " { $snippet "p" } " and " { $snippet "q" } "." }
+{ $examples
+ { $example "USING: kernel math.polynomials prettyprint ;"
+ "{ 1 1 1 1 } { 1 1 } pgcd [ . ] bi@"
+ "{ 0 0 }\n{ 1 1 }"
+ }
+} ;
+
+HELP: pdiff
+{ $values { "p" "a polynomial" } { "p'" "a polynomial" } }
+{ $description "Finds the derivative of " { $snippet "p" } "." } ;
+
+HELP: polyval
+{ $values { "p" "a polynomial" } { "x" number } { "p[x]" number } }
+{ $description "Evaluate " { $snippet "p" } " with the input " { $snippet "x" } "." }
+{ $examples { $example "USING: math.polynomials prettyprint ;" "{ 1 0 1 } 2 polyval ." "5" } } ;
+
-IN: math.polynomials.tests
USING: kernel math math.polynomials tools.test ;
+IN: math.polynomials.tests
-! Tests
[ { 0 1 } ] [ { 0 1 0 0 } ptrim ] unit-test
[ { 1 } ] [ { 1 0 0 } ptrim ] unit-test
[ { 0 } ] [ { 0 } ptrim ] unit-test
splitting vectors ;
IN: math.polynomials
-! Polynomials are vectors with the highest powers on the right:
-! { 1 1 0 1 } -> 1 + x + x^3
-! { } -> 0
-
-: powers ( n x -- seq )
- #! Output sequence has n elements, { 1 x x^2 x^3 ... }
- <array> 1 [ * ] accumulate nip ;
-
<PRIVATE
-: 2pad-left ( p p n -- p p ) [ 0 pad-left ] curry bi@ ;
-: 2pad-right ( p p n -- p p ) [ 0 pad-right ] curry bi@ ;
-: pextend ( p p -- p p ) 2dup [ length ] bi@ max 2pad-right ;
-: pextend-left ( p p -- p p ) 2dup [ length ] bi@ max 2pad-left ;
+: 2pad-left ( p q n -- p q ) [ 0 pad-left ] curry bi@ ;
+: 2pad-right ( p q n -- p q ) [ 0 pad-right ] curry bi@ ;
+: pextend ( p q -- p q ) 2dup [ length ] bi@ max 2pad-right ;
+: pextend-left ( p q -- p q ) 2dup [ length ] bi@ max 2pad-left ;
: unempty ( seq -- seq ) [ { 0 } ] when-empty ;
: 2unempty ( seq seq -- seq seq ) [ unempty ] bi@ ;
PRIVATE>
-: p= ( p p -- ? ) pextend = ;
+: powers ( n x -- seq )
+ <array> 1 [ * ] accumulate nip ;
+
+: p= ( p q -- ? ) pextend = ;
: ptrim ( p -- p )
dup length 1 = [ [ zero? ] trim-right ] unless ;
-: 2ptrim ( p p -- p p ) [ ptrim ] bi@ ;
-: p+ ( p p -- p ) pextend v+ ;
-: p- ( p p -- p ) pextend v- ;
+: 2ptrim ( p q -- p q ) [ ptrim ] bi@ ;
+: p+ ( p q -- r ) pextend v+ ;
+: p- ( p q -- r ) pextend v- ;
: n*p ( n p -- n*p ) n*v ;
-! convolution
-: pextend-conv ( p p -- p p )
- #! extend to: p_m + p_n - 1
+: pextend-conv ( p q -- p q )
2dup [ length ] bi@ + 1- 2pad-right [ >vector ] bi@ ;
-: p* ( p p -- p )
- #! Multiply two polynomials.
+: p* ( p q -- r )
2unempty pextend-conv <reversed> dup length
[ over length pick <slice> pick [ * ] 2map sum ] map 2nip reverse ;
-: p-sq ( p -- p-sq )
+: p-sq ( p -- p^2 )
dup p* ;
<PRIVATE
PRIVATE>
-: p/mod ( a b -- / mod )
+: p/mod ( p q -- z w )
p/mod-setup [ [ (p/mod) ] times ] V{ } make
reverse nip swap 2ptrim pextend ;
+<PRIVATE
+
: (pgcd) ( b a y x -- a d )
dup V{ 0 } clone p= [
drop nip
tuck p/mod [ pick p* swap [ swapd p- ] dip ] dip (pgcd)
] if ;
-: pgcd ( p p -- p q )
+PRIVATE>
+
+: pgcd ( p q -- a d )
swap V{ 0 } clone V{ 1 } clone 2swap (pgcd) [ >array ] bi@ ;
: pdiff ( p -- p' )
- #! Polynomial derivative.
dup length v* { 0 } ?head drop ;
: polyval ( p x -- p[x] )
- #! Evaluate a polynomial.
[ dup length ] dip powers v. ;
--- /dev/null
+USING: help.markup help.syntax math math.vectors vectors ;
+IN: math.quaternions
+
+HELP: q*
+{ $values { "u" "a quaternion" } { "v" "a quaternion" } { "u*v" "a quaternion" } }
+{ $description "Multiply quaternions." }
+{ $examples { $example "USING: math.quaternions prettyprint ;" "{ C{ 0 1 } 0 } { 0 1 } q* ." "{ 0 C{ 0 1 } }" } } ;
+
+HELP: qconjugate
+{ $values { "u" "a quaternion" } { "u'" "a quaternion" } }
+{ $description "Quaternion conjugate." } ;
+
+HELP: qrecip
+{ $values { "u" "a quaternion" } { "1/u" "a quaternion" } }
+{ $description "Quaternion inverse." } ;
+
+HELP: q/
+{ $values { "u" "a quaternion" } { "v" "a quaternion" } { "u/v" "a quaternion" } }
+{ $description "Divide quaternions." }
+{ $examples { $example "USING: math.quaternions prettyprint ;" "{ 0 C{ 0 1 } } { 0 1 } q/ ." "{ C{ 0 1 } 0 }" } } ;
+
+HELP: q*n
+{ $values { "q" "a quaternion" } { "n" number } { "q" "a quaternion" } }
+{ $description "Multiplies each element of " { $snippet "q" } " by " { $snippet "n" } "." }
+{ $notes "You will get the wrong result if you try to multiply a quaternion by a complex number on the right using " { $link v*n } ". Use this word instead."
+ $nl "Note that " { $link v*n } " with a quaternion and a real is okay." } ;
+
+HELP: c>q
+{ $values { "c" number } { "q" "a quaternion" } }
+{ $description "Turn a complex number into a quaternion." }
+{ $examples { $example "USING: math.quaternions prettyprint ;" "C{ 0 1 } c>q ." "{ C{ 0 1 } 0 }" } } ;
+
+HELP: v>q
+{ $values { "v" vector } { "q" "a quaternion" } }
+{ $description "Turn a 3-vector into a quaternion with real part 0." }
+{ $examples { $example "USING: math.quaternions prettyprint ;" "{ 1 0 0 } v>q ." "{ C{ 0 1 } 0 }" } } ;
+
+HELP: q>v
+{ $values { "q" "a quaternion" } { "v" vector } }
+{ $description "Get the vector part of a quaternion, discarding the real part." }
+{ $examples { $example "USING: math.quaternions prettyprint ;" "{ C{ 0 1 } 0 } q>v ." "{ 1 0 0 }" } } ;
+
+HELP: euler
+{ $values { "phi" number } { "theta" number } { "psi" number } { "q" "a quaternion" } }
+{ $description "Convert a rotation given by Euler angles (phi, theta, and psi) to a quaternion." } ;
+
! Copyright (C) 2005, 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
+USING: arrays kernel math math.functions math.vectors sequences ;
+IN: math.quaternions
-! Everybody's favorite non-commutative skew field, the
-! quaternions!
+! Everybody's favorite non-commutative skew field, the quaternions!
-! Quaternions are represented as pairs of complex numbers,
-! using the identity: (a+bi)+(c+di)j = a+bi+cj+dk.
-USING: arrays kernel math math.vectors math.functions
-arrays sequences ;
-IN: math.quaternions
+! Quaternions are represented as pairs of complex numbers, using the
+! identity: (a+bi)+(c+di)j = a+bi+cj+dk.
<PRIVATE
PRIVATE>
: q* ( u v -- u*v )
- #! Multiply quaternions.
[ q*a ] [ q*b ] 2bi 2array ;
: qconjugate ( u -- u' )
- #! Quaternion conjugate.
first2 [ conjugate ] [ neg ] bi* 2array ;
: qrecip ( u -- 1/u )
- #! Quaternion inverse.
qconjugate dup norm-sq v/n ;
: q/ ( u v -- u/v )
- #! Divide quaternions.
qrecip q* ;
: q*n ( q n -- q )
- #! Note: you will get the wrong result if you try to
- #! multiply a quaternion by a complex number on the right
- #! using v*n. Use this word instead. Note that v*n with a
- #! quaternion and a real is okay.
conjugate v*n ;
: c>q ( c -- q )
- #! Turn a complex number into a quaternion.
0 2array ;
: v>q ( v -- q )
- #! Turn a 3-vector into a quaternion with real part 0.
first3 rect> [ 0 swap rect> ] dip 2array ;
: q>v ( q -- v )
- #! Get the vector part of a quaternion, discarding the real
- #! part.
first2 [ imaginary-part ] dip >rect 3array ;
! Zero
: qj { 0 1 } ;
: qk { 0 C{ 0 1 } } ;
-! Euler angles -- see
-! http://www.mathworks.com/access/helpdesk/help/toolbox/aeroblks/euleranglestoquaternions.html
+! Euler angles
+
+<PRIVATE
: (euler) ( theta unit -- q )
- [ -0.5 * dup cos c>q swap sin ] dip n*v v- ;
+ [ -0.5 * [ cos c>q ] [ sin ] bi ] dip n*v v- ;
+
+PRIVATE>
: euler ( phi theta psi -- q )
[ qi (euler) ] [ qj (euler) ] [ qk (euler) ] tri* q* q* ;
! Copyright (C) 2008 Doug Coleman, Michael Judge.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays kernel math math.analysis math.functions sequences sequences.lib
- sorting ;
+USING: arrays combinators kernel math math.analysis math.functions sequences
+ sequences.lib sorting ;
IN: math.statistics
: mean ( seq -- n )
r sq ;
: least-squares ( {{x,y}...} -- alpha beta )
- [r] >r >r >r >r 2dup r> r> r> r>
+ [r] { [ 2dup ] [ ] [ ] [ ] [ ] } spread
! stack is mean(x) mean(y) mean(x) mean(y) {x} {y} sx sy
[ (r) ] 2keep ! stack is mean(x) mean(y) r sx sy
swap / * ! stack is mean(x) mean(y) beta
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-
-USING: kernel io parser lexer words namespaces quotations arrays assocs sequences
- splitting grouping math generalizations ;
-
-IN: mortar
-
-! class { name slots methods class-methods }
-
-: class-name ( class -- name ) dup symbol? [ get ] when first ;
-
-: class-slots ( class -- slots ) dup symbol? [ get ] when second ;
-
-: class-methods ( class -- methods ) dup symbol? [ get ] when third ;
-
-: class-class-methods ( class -- methods ) dup symbol? [ get ] when fourth ;
-
-: class? ( thing -- ? )
-dup array?
-[ dup length 4 = [ first symbol? ] [ drop f ] if ]
-[ drop f ]
-if ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: add-method ( class name quot -- )
-rot get class-methods peek swapd set-at ;
-
-: add-class-method ( class name quot -- )
-rot get class-class-methods peek swapd set-at ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! object { class values }
-
-: object-class ( object -- class ) first ;
-
-: object-values ( object -- values ) second ;
-
-: object? ( thing -- ? )
-dup array?
-[ dup length 2 = [ first class? ] [ drop f ] if ]
-[ drop f ]
-if ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: is? ( object class -- ? ) swap object-class class-name = ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: new ( class -- object )
-get dup >r class-slots length narray r> swap 2array ;
-
-: new-empty ( class -- object )
-get dup >r class-slots length f <array> r> swap 2array ;
-
-! : new* ( class -- object ) new-empty <- init ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: slot-value ( object slot -- value )
-over object-class class-slots index swap object-values nth ;
-
-: set-slot-value ( object slot value -- object )
-swap pick object-class class-slots index pick object-values set-nth ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! : send-message ( object message -- )
-! over object-class class-methods assoc-stack call ;
-
-: send-message ( object message -- )
-2dup swap object-class class-methods assoc-stack dup
-[ nip call ]
-! [ drop nip "message not understood: " write print flush ]
-[ drop "message not understood: " write print drop ]
-if ;
-
-: <- scan parsed \ send-message parsed ; parsing
-
-! : send-message* ( message n -- )
-! 1+ npick object-class class-methods assoc-stack call ;
-
-: send-message* ( message n -- )
-1+ npick dupd object-class class-methods assoc-stack dup
-[ nip call ]
-[ drop "message not understood: " write print flush ]
-if ;
-
-: <-- scan parsed 2 parsed \ send-message* parsed ; parsing
-
-: <--- scan parsed 3 parsed \ send-message* parsed ; parsing
-
-: <---- scan parsed 4 parsed \ send-message* parsed ; parsing
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: send-message-to-class ( class message -- )
-over class-class-methods assoc-stack call ;
-
-: <<- scan parsed \ send-message-to-class parsed ; parsing
-
-: send-message-to-class* ( message n -- )
-1+ npick class-class-methods assoc-stack call ;
-
-: <<-- scan parsed 2 parsed \ send-message-to-class* parsed ; parsing
-
-: <<--- scan parsed 3 parsed \ send-message-to-class* parsed ; parsing
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: send-message-next ( object message -- )
-over object-class class-methods but-last assoc-stack call ;
-
-: <-~ scan parsed \ send-message-next parsed ; parsing
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! : new* ( class -- object ) <<- create ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-IN: slot-accessors
-
-IN: mortar
-
-! : generate-slot-getter ( name -- )
-! "$" over append "slot-accessors" create swap [ slot-value ] curry
-! define-compound ;
-
-: generate-slot-getter ( name -- )
-"$" over append "slot-accessors" create swap [ slot-value ] curry define ;
-
-! : generate-slot-setter ( name -- )
-! ">>" over append "slot-accessors" create swap [ swap set-slot-value ] curry
-! define-compound ;
-
-: generate-slot-setter ( name -- )
-">>" over append "slot-accessors" create swap [ swap set-slot-value ] curry
-define ;
-
-: generate-slot-accessors ( name -- )
-dup
-generate-slot-getter
-generate-slot-setter ;
-
-: accessors ( seq -- seq ) dup peek [ generate-slot-accessors ] each ; parsing
-
-! : slots:
-! ";" parse-tokens dup [ generate-slot-accessors ] each parsed ; parsing
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! : <symbol> ( string -- symbol ) in get create dup define-symbol ;
-
-: empty-method-table ( -- array ) H{ } clone 1array ;
-
-! : define-simple-class ( name parent slots -- )
-! >r >r <symbol>
-! r> dup class-slots r> append
-! swap dup class-methods empty-method-table append
-! swap class-class-methods empty-method-table append
-! 4array dup first set-global ;
-
-: define-simple-class ( name parent slots -- )
->r dup class-slots r> append
-swap dup class-methods empty-method-table append
-swap class-class-methods empty-method-table append
-4array dup first set-global ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: define-independent-class ( name slots -- )
-empty-method-table empty-method-table 4array dup first set-global ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: add-methods ( class seq -- ) 2 group [ first2 add-method ] with each ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: !( ")" parse-tokens drop ; parsing
\ No newline at end of file
+++ /dev/null
-
-USING: mortar ;
-
-IN: mortar.sugar
-
-: new* ( class -- object ) <<- create ;
\ No newline at end of file
+++ /dev/null
-extensions
+++ /dev/null
-Chris Double
+++ /dev/null
-! Copyright (C) 2007 Chris Double.\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: help.syntax help.markup threads ;\r
-\r
-IN: odbc\r
-\r
-HELP: odbc-init \r
-{ $values { "env" "an ODBC environment handle" } } \r
-{ $description \r
- "Initializes the ODBC driver manager and returns the " \r
- "environment handle required by " { $link odbc-connect } "."\r
-} \r
-{ $see-also odbc-init odbc-connect odbc-disconnect odbc-prepare odbc-free-statement odbc-execute odbc-next-row odbc-number-of-columns odbc-describe-column odbc-get-field odbc-get-row-fields odbc-get-all-rows odbc-query } ;\r
-\r
-HELP: odbc-connect \r
-{ $values { "env" "an ODBC environment handle" } { "dsn" "a string" } { "dbc" "an ODBC database connection handle" } } \r
-{ $description \r
- "Connects to the database identified by the ODBC data source name (DSN). " \r
- "The environment handle is usually obtained by a call to " { $link odbc-init } ". The result is the ODBC connection handle which can be used in other ODBC calls. When finished with the connection handle " { $link odbc-disconnect } " must be called on it."\r
-} \r
-{ $examples { $code "dbc get \"DSN=mydsn\" odbc-connect" } }\r
-{ $see-also odbc-init odbc-connect odbc-disconnect odbc-prepare odbc-free-statement odbc-execute odbc-next-row odbc-number-of-columns odbc-describe-column odbc-get-field odbc-get-row-fields odbc-get-all-rows odbc-query } ;\r
-\r
-HELP: odbc-disconnect \r
-{ $values { "dbc" "an ODBC database connection handle" } } \r
-{ $description \r
- "Disconnects from the given database." \r
-} \r
-{ $see-also odbc-init odbc-connect odbc-disconnect odbc-prepare odbc-free-statement odbc-execute odbc-next-row odbc-number-of-columns odbc-describe-column odbc-get-field odbc-get-row-fields odbc-get-all-rows odbc-query } ;\r
-\r
-HELP: odbc-prepare\r
-{ $values { "dbc" "an ODBC database connection handle" } { "string" "a string containing SQL" } { "statement" "an ODBC statement handle" } } \r
-{ $description \r
- "Prepares (precompiles) the given SQL string, ready for execution with " { $link odbc-execute } ". When finished with the statement " { $link odbc-free-statement } " must be called on it." \r
-} \r
-{ $see-also odbc-init odbc-connect odbc-disconnect odbc-prepare odbc-free-statement odbc-execute odbc-next-row odbc-number-of-columns odbc-describe-column odbc-get-field odbc-get-row-fields odbc-get-all-rows odbc-query } ;\r
-\r
-HELP: odbc-free-statement\r
-{ $values { "statement" "an ODBC statement handle" } } \r
-{ $description \r
- "Closes the statement handle and frees up all resources associated with it." \r
-} \r
-{ $see-also odbc-init odbc-connect odbc-disconnect odbc-prepare odbc-free-statement odbc-execute odbc-next-row odbc-number-of-columns odbc-describe-column odbc-get-field odbc-get-row-fields odbc-get-all-rows odbc-query } ;\r
-\r
-HELP: odbc-execute\r
-{ $values { "statement" "an ODBC statement handle" } } \r
-{ $description \r
- "Executes the statement. Once this is done " { $link odbc-next-row } " can be called to retrieve rows." \r
-} \r
-{ $see-also odbc-init odbc-connect odbc-disconnect odbc-prepare odbc-free-statement odbc-execute odbc-next-row odbc-number-of-columns odbc-describe-column odbc-get-field odbc-get-row-fields odbc-get-all-rows odbc-query } ;\r
-\r
-HELP: odbc-next-row\r
-{ $values { "statement" "an ODBC statement handle" } { "bool" "a boolean indicating success or failure" } } \r
-{ $description \r
- "Retrieves the next available row from the database. If no next row is available then " { $link f } " is returned. Once the row is retrieved " { $link odbc-number-of-columns } ", " { $link odbc-describe-column } ", " { $link odbc-get-field } " and " { $link odbc-get-row-fields } " can be used to query the data retrieved." \r
-} \r
-{ $see-also odbc-init odbc-connect odbc-disconnect odbc-prepare odbc-free-statement odbc-execute odbc-next-row odbc-number-of-columns odbc-describe-column odbc-get-field odbc-get-row-fields odbc-get-all-rows odbc-query } ;\r
-\r
-HELP: odbc-number-of-columns\r
-{ $values { "statement" "an ODBC statement handle" } { "number" "a number" } } \r
-{ $description \r
- "Returns the number of columns of data retrieved."\r
-} \r
-{ $see-also odbc-init odbc-connect odbc-disconnect odbc-prepare odbc-free-statement odbc-execute odbc-next-row odbc-number-of-columns odbc-describe-column odbc-get-field odbc-get-row-fields odbc-get-all-rows odbc-query } ;\r
-\r
-HELP: odbc-describe-column\r
-{ $values { "statement" "an ODBC statement handle" } { "n" "a column number starting from one" } { "column" "a column object" } } \r
-{ $description \r
- "Retrieves column information for the given column number from the statement. The column number must be one or greater. The " { $link <column> } " object returned provides data type, name, etc."\r
-} \r
-{ $see-also odbc-init odbc-connect odbc-disconnect odbc-prepare odbc-free-statement odbc-execute odbc-next-row odbc-number-of-columns odbc-describe-column odbc-get-field odbc-get-row-fields odbc-get-all-rows odbc-query } ;\r
-\r
-HELP: odbc-get-field\r
-{ $values { "statement" "an ODBC statement handle" } { "column" "a column number starting from one or a <column> object" } { "field" "a <field> object" } } \r
-{ $description \r
- "Returns a field object which contains the data for the field in the given column in the current row. The column can be identified by a number or a <column> object. The datatype of the contents of the field depends on the type of the column itself. Note that this word can only be safely called once on each column in a given row with most ODBC drivers. Subsequent calls on the same row for the same column can fail."\r
-} \r
-{ $see-also odbc-init odbc-connect odbc-disconnect odbc-prepare odbc-free-statement odbc-execute odbc-next-row odbc-number-of-columns odbc-describe-column odbc-get-field odbc-get-row-fields odbc-get-all-rows odbc-query } ;\r
-\r
-HELP: odbc-get-row-fields\r
-{ $values { "statement" "an ODBC statement handle" } { "seq" "a sequence" } } \r
-{ $description \r
- "Returns a sequence of all field data for the current row. Note that this isnot the <field> objects, but the data for that field. This word can only be called once on a given row. Subsequent calls on the same row may fail on some ODBC drivers."\r
-} \r
-{ $see-also odbc-init odbc-connect odbc-disconnect odbc-prepare odbc-free-statement odbc-execute odbc-next-row odbc-number-of-columns odbc-describe-column odbc-get-field odbc-get-row-fields odbc-get-all-rows odbc-query } ;\r
-\r
-HELP: odbc-get-all-rows\r
-{ $values { "statement" "an ODBC statement handle" } { "seq" "a sequence" } } \r
-{ $description \r
- "Returns a sequence of all rows available from the statement. Effectively it is the contents of the entire query so may take some time and memory. Each element of the sequence is itself a sequence containing the data for that row. A " { $link yield } " is performed an various intervals so as to not lock up the Factor instance while it is running."\r
-} \r
-{ $see-also odbc-init odbc-connect odbc-disconnect odbc-prepare odbc-free-statement odbc-execute odbc-next-row odbc-number-of-columns odbc-describe-column odbc-get-field odbc-get-row-fields odbc-get-all-rows odbc-query } ;\r
-\r
-HELP: odbc-query\r
-{ $values { "string" "a string containing SQL" } { "dsn" "a DSN string" } { "result" "a sequence" } } \r
-{ $description \r
- "This word initializes odbc, connects to the database with the given DSN, executes the query string and returns the result as a sequence. It cleans up all resources it uses. It is an inefficient way of running multiple queries but is useful for the occasional query, testing at the REPL, or as an example of how to do it."\r
-} \r
-{ $see-also odbc-init odbc-connect odbc-disconnect odbc-prepare odbc-free-statement odbc-execute odbc-next-row odbc-number-of-columns odbc-describe-column odbc-get-field odbc-get-row-fields odbc-get-all-rows odbc-query } ;\r
+++ /dev/null
-! Copyright (C) 2007 Chris Double.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel alien alien.strings alien.syntax
-combinators alien.c-types strings sequences namespaces make
-words math threads io.encodings.ascii ;
-IN: odbc
-
-<< "odbc" "odbc32.dll" "stdcall" add-library >>
-
-LIBRARY: odbc
-
-TYPEDEF: void* usb_dev_handle*
-TYPEDEF: short SQLRETURN
-TYPEDEF: short SQLSMALLINT
-TYPEDEF: short* SQLSMALLINT*
-TYPEDEF: ushort SQLUSMALLINT
-TYPEDEF: uint* SQLUINTEGER*
-TYPEDEF: int SQLINTEGER
-TYPEDEF: char SQLCHAR
-TYPEDEF: char* SQLCHAR*
-TYPEDEF: void* SQLHANDLE
-TYPEDEF: void* SQLHANDLE*
-TYPEDEF: void* SQLHENV
-TYPEDEF: void* SQLHDBC
-TYPEDEF: void* SQLHSTMT
-TYPEDEF: void* SQLHWND
-TYPEDEF: void* SQLPOINTER
-
-: SQL-HANDLE-ENV ( -- number ) 1 ; inline
-: SQL-HANDLE-DBC ( -- number ) 2 ; inline
-: SQL-HANDLE-STMT ( -- number ) 3 ; inline
-: SQL-HANDLE-DESC ( -- number ) 4 ; inline
-
-: SQL-NULL-HANDLE ( -- alien ) f ; inline
-
-: SQL-ATTR-ODBC-VERSION ( -- number ) 200 ; inline
-
-: SQL-OV-ODBC2 ( -- number ) 2 <alien> ; inline
-: SQL-OV-ODBC3 ( -- number ) 3 <alien> ; inline
-
-: SQL-SUCCESS ( -- number ) 0 ; inline
-: SQL-SUCCESS-WITH-INFO ( -- number ) 1 ; inline
-: SQL-NO-DATA-FOUND ( -- number ) 100 ; inline
-
-: SQL-DRIVER-NOPROMPT ( -- number ) 0 ; inline
-: SQL-DRIVER-PROMPT ( -- number ) 2 ; inline
-
-: SQL-C-DEFAULT ( -- number ) 99 ; inline
-
-SYMBOL: SQL-CHAR
-SYMBOL: SQL-VARCHAR
-SYMBOL: SQL-LONGVARCHAR
-SYMBOL: SQL-WCHAR
-SYMBOL: SQL-WCHARVAR
-SYMBOL: SQL-WLONGCHARVAR
-SYMBOL: SQL-DECIMAL
-SYMBOL: SQL-SMALLINT
-SYMBOL: SQL-NUMERIC
-SYMBOL: SQL-INTEGER
-SYMBOL: SQL-REAL
-SYMBOL: SQL-FLOAT
-SYMBOL: SQL-DOUBLE
-SYMBOL: SQL-BIT
-SYMBOL: SQL-TINYINT
-SYMBOL: SQL-BIGINT
-SYMBOL: SQL-BINARY
-SYMBOL: SQL-VARBINARY
-SYMBOL: SQL-LONGVARBINARY
-SYMBOL: SQL-TYPE-DATE
-SYMBOL: SQL-TYPE-TIME
-SYMBOL: SQL-TYPE-TIMESTAMP
-SYMBOL: SQL-TYPE-UTCDATETIME
-SYMBOL: SQL-TYPE-UTCTIME
-SYMBOL: SQL-INTERVAL-MONTH
-SYMBOL: SQL-INTERVAL-YEAR
-SYMBOL: SQL-INTERVAL-YEAR-TO-MONTH
-SYMBOL: SQL-INTERVAL-DAY
-SYMBOL: SQL-INTERVAL-HOUR
-SYMBOL: SQL-INTERVAL-MINUTE
-SYMBOL: SQL-INTERVAL-SECOND
-SYMBOL: SQL-INTERVAL-DAY-TO-HOUR
-SYMBOL: SQL-INTERVAL-DAY-TO-MINUTE
-SYMBOL: SQL-INTERVAL-DAY-TO-SECOND
-SYMBOL: SQL-INTERVAL-HOUR-TO-MINUTE
-SYMBOL: SQL-INTERVAL-HOUR-TO-SECOND
-SYMBOL: SQL-INTERVAL-MINUTE-TO-SECOND
-SYMBOL: SQL-GUID
-SYMBOL: SQL-TYPE-UNKNOWN
-
-: convert-sql-type ( number -- symbol )
- {
- { 1 [ SQL-CHAR ] }
- { 12 [ SQL-VARCHAR ] }
- { -1 [ SQL-LONGVARCHAR ] }
- { -8 [ SQL-WCHAR ] }
- { -9 [ SQL-WCHARVAR ] }
- { -10 [ SQL-WLONGCHARVAR ] }
- { 3 [ SQL-DECIMAL ] }
- { 5 [ SQL-SMALLINT ] }
- { 2 [ SQL-NUMERIC ] }
- { 4 [ SQL-INTEGER ] }
- { 7 [ SQL-REAL ] }
- { 6 [ SQL-FLOAT ] }
- { 8 [ SQL-DOUBLE ] }
- { -7 [ SQL-BIT ] }
- { -6 [ SQL-TINYINT ] }
- { -5 [ SQL-BIGINT ] }
- { -2 [ SQL-BINARY ] }
- { -3 [ SQL-VARBINARY ] }
- { -4 [ SQL-LONGVARBINARY ] }
- { 91 [ SQL-TYPE-DATE ] }
- { 92 [ SQL-TYPE-TIME ] }
- { 93 [ SQL-TYPE-TIMESTAMP ] }
- [ drop SQL-TYPE-UNKNOWN ]
- } case ;
-
-: succeeded? ( n -- bool )
- #! Did the call succeed (SQL-SUCCESS or SQL-SUCCESS-WITH-INFO)
- {
- { SQL-SUCCESS [ t ] }
- { SQL-SUCCESS-WITH-INFO [ t ] }
- [ drop f ]
- } case ;
-
-FUNCTION: SQLRETURN SQLAllocHandle ( SQLSMALLINT handleType, SQLHANDLE inputHandle, SQLHANDLE* outputHandlePtr ) ;
-FUNCTION: SQLRETURN SQLSetEnvAttr ( SQLHENV environmentHandle, SQLINTEGER attribute, SQLPOINTER valuePtr, SQLINTEGER stringLength ) ;
-FUNCTION: SQLRETURN SQLDriverConnect ( SQLHDBC connectionHandle, SQLHWND windowHandle, SQLCHAR* inConnectionString, SQLSMALLINT stringLength, SQLCHAR* outConnectionString, SQLSMALLINT bufferLength, SQLSMALLINT* stringLength2Ptr, SQLUSMALLINT driverCompletion ) ;
-FUNCTION: SQLRETURN SQLDisconnect ( SQLHDBC connectionHandle ) ;
-FUNCTION: SQLRETURN SQLPrepare ( SQLHSTMT statementHandle, SQLCHAR* statementText, SQLINTEGER length ) ;
-FUNCTION: SQLRETURN SQLExecute ( SQLHSTMT statementHandle ) ;
-FUNCTION: SQLRETURN SQLFreeHandle ( SQLSMALLINT handleType, SQLHANDLE handle ) ;
-FUNCTION: SQLRETURN SQLFetch ( SQLHSTMT statementHandle ) ;
-FUNCTION: SQLRETURN SQLNumResultCols ( SQLHSTMT statementHandle, SQLSMALLINT* columnCountPtr ) ;
-FUNCTION: SQLRETURN SQLDescribeCol ( SQLHSTMT statementHandle, SQLSMALLINT columnNumber, SQLCHAR* columnName, SQLSMALLINT bufferLength, SQLSMALLINT* nameLengthPtr, SQLSMALLINT* dataTypePtr, SQLUINTEGER* columnSizePtr, SQLSMALLINT* decimalDigitsPtr, SQLSMALLINT* nullablePtr ) ;
-FUNCTION: SQLRETURN SQLGetData ( SQLHSTMT statementHandle, SQLUSMALLINT columnNumber, SQLSMALLINT targetType, SQLPOINTER targetValuePtr, SQLINTEGER bufferLength, SQLINTEGER* strlen_or_indPtr ) ;
-
-: alloc-handle ( type parent -- handle )
- f <void*> [ SQLAllocHandle ] keep swap succeeded? [
- *void*
- ] [
- drop f
- ] if ;
-
-: alloc-env-handle ( -- handle )
- SQL-HANDLE-ENV SQL-NULL-HANDLE alloc-handle ;
-
-: alloc-dbc-handle ( env -- handle )
- SQL-HANDLE-DBC swap alloc-handle ;
-
-: alloc-stmt-handle ( dbc -- handle )
- SQL-HANDLE-STMT swap alloc-handle ;
-
-: temp-string ( length -- byte-array length )
- [ CHAR: \space <string> ascii string>alien ] keep ;
-
-: odbc-init ( -- env )
- alloc-env-handle
- [
- SQL-ATTR-ODBC-VERSION SQL-OV-ODBC3 0 SQLSetEnvAttr
- succeeded? [ "odbc-init failed" throw ] unless
- ] keep ;
-
-: odbc-connect ( env dsn -- dbc )
- >r alloc-dbc-handle dup r>
- f swap dup length 1024 temp-string 0 <short> SQL-DRIVER-NOPROMPT
- SQLDriverConnect succeeded? [ "odbc-connect failed" throw ] unless ;
-
-: odbc-disconnect ( dbc -- )
- SQLDisconnect succeeded? [ "odbc-disconnect failed" throw ] unless ;
-
-: odbc-prepare ( dbc string -- statement )
- >r alloc-stmt-handle dup r> dup length SQLPrepare succeeded? [ "odbc-prepare failed" throw ] unless ;
-
-: odbc-free-statement ( statement -- )
- SQL-HANDLE-STMT swap SQLFreeHandle succeeded? [ "odbc-free-statement failed" throw ] unless ;
-
-: odbc-execute ( statement -- )
- SQLExecute succeeded? [ "odbc-execute failed" throw ] unless ;
-
-: odbc-next-row ( statement -- bool )
- SQLFetch succeeded? ;
-
-: odbc-number-of-columns ( statement -- number )
- 0 <short> [ SQLNumResultCols succeeded? ] keep swap [
- *short
- ] [
- drop f
- ] if ;
-
-TUPLE: column nullable digits size type name number ;
-
-C: <column> column
-
-: odbc-describe-column ( statement n -- column )
- dup >r
- 1024 CHAR: \space <string> ascii string>alien dup >r
- 1024
- 0 <short>
- 0 <short> dup >r
- 0 <uint> dup >r
- 0 <short> dup >r
- 0 <short> dup >r
- SQLDescribeCol succeeded? [
- r> *short
- r> *short
- r> *uint
- r> *short convert-sql-type
- r> ascii alien>string
- r> <column>
- ] [
- r> drop r> drop r> drop r> drop r> drop r> drop
- "odbc-describe-column failed" throw
- ] if ;
-
-: dereference-type-pointer ( byte-array column -- object )
- type>> {
- { SQL-CHAR [ ascii alien>string ] }
- { SQL-VARCHAR [ ascii alien>string ] }
- { SQL-LONGVARCHAR [ ascii alien>string ] }
- { SQL-WCHAR [ ascii alien>string ] }
- { SQL-WCHARVAR [ ascii alien>string ] }
- { SQL-WLONGCHARVAR [ ascii alien>string ] }
- { SQL-SMALLINT [ *short ] }
- { SQL-INTEGER [ *long ] }
- { SQL-REAL [ *float ] }
- { SQL-FLOAT [ *double ] }
- { SQL-DOUBLE [ *double ] }
- { SQL-TINYINT [ *char ] }
- { SQL-BIGINT [ *longlong ] }
- [ nip [ "Unknown SQL Type: " % name>> % ] "" make ]
- } case ;
-
-TUPLE: field value column ;
-
-C: <field> field
-
-: odbc-get-field ( statement column -- field )
- dup column? [ dupd odbc-describe-column ] unless dup >r number>>
- SQL-C-DEFAULT
- 8192 CHAR: \space <string> ascii string>alien dup >r
- 8192
- f SQLGetData succeeded? [
- r> r> [ dereference-type-pointer ] keep <field>
- ] [
- r> drop r> [
- "SQLGetData Failed for Column: " %
- dup name>> %
- " of type: " % dup type>> name>> %
- ] "" make swap <field>
- ] if ;
-
-: odbc-get-row-fields ( statement -- seq )
- [
- dup odbc-number-of-columns [
- 1+ odbc-get-field value>> ,
- ] with each
- ] { } make ;
-
-: (odbc-get-all-rows) ( statement -- )
- dup odbc-next-row [ dup odbc-get-row-fields , yield (odbc-get-all-rows) ] [ drop ] if ;
-
-: odbc-get-all-rows ( statement -- seq )
- [ (odbc-get-all-rows) ] { } make ;
-
-: odbc-query ( string dsn -- result )
- odbc-init swap odbc-connect [
- swap odbc-prepare
- dup odbc-execute
- dup odbc-get-all-rows
- swap odbc-free-statement
- ] keep odbc-disconnect ;
+++ /dev/null
-ODBC (Open DataBase Connectivity) binding
opengl
-glsl
bindings
\ No newline at end of file
text
javascript
parsing
+languages
text
javascript
parsing
+languages
text
javascript
parsing
+languages
text
javascript
parsing
+languages
<PRIVATE
: (consecutive) ( count goal test -- n )
- pick pick = [
+ 2over = [
swap - nip
] [
dup prime? [ [ drop 0 ] 2dip ] [
--- /dev/null
+USING: project-euler.099 project-euler.099.private tools.test ;
+IN: project-euler.099.tests
+
+[ 2 ] [ { { 2 11 } { 3 7 } } solve ] unit-test
+[ 709 ] [ euler099 ] unit-test
--- /dev/null
+! Copyright (c) 2008 Aaron Schaefer.
+! See http://factorcode.org/license.txt for BSD license.
+USING: io.encodings.ascii io.files kernel math math.functions math.parser
+ math.vectors sequences splitting ;
+IN: project-euler.099
+
+! http://projecteuler.net/index.php?section=problems&id=99
+
+! DESCRIPTION
+! -----------
+
+! Comparing two numbers written in index form like 2^11 and 3^7 is not difficult,
+! as any calculator would confirm that 2^11 = 2048 < 3^7 = 2187.
+
+! However, confirming that 632382^518061 519432^525806 would be much more
+! difficult, as both numbers contain over three million digits.
+
+! Using base_exp.txt (right click and 'Save Link/Target As...'), a 22K text
+! file containing one thousand lines with a base/exponent pair on each line,
+! determine which line number has the greatest numerical value.
+
+! NOTE: The first two lines in the file represent the numbers in the example
+! given above.
+
+
+! SOLUTION
+! --------
+
+! Use logarithms to make the calculations necessary more manageable.
+
+<PRIVATE
+
+: source-099 ( -- seq )
+ "resource:extra/project-euler/099/base_exp.txt"
+ ascii file-lines [ "," split [ string>number ] map ] map ;
+
+: simplify ( seq -- seq )
+ #! exponent * log(base)
+ flip first2 swap [ log ] map v* ;
+
+: solve ( seq -- index )
+ simplify [ supremum ] keep index 1+ ;
+
+PRIVATE>
+
+: euler099 ( -- answer )
+ source-099 solve ;
+
+! [ euler099 ] 100 ave-time
+! 16 ms ave run timen - 1.67 SD (100 trials)
+
+MAIN: euler099
--- /dev/null
+519432,525806\r
+632382,518061\r
+78864,613712\r
+466580,530130\r
+780495,510032\r
+525895,525320\r
+15991,714883\r
+960290,502358\r
+760018,511029\r
+166800,575487\r
+210884,564478\r
+555151,523163\r
+681146,515199\r
+563395,522587\r
+738250,512126\r
+923525,503780\r
+595148,520429\r
+177108,572629\r
+750923,511482\r
+440902,532446\r
+881418,505504\r
+422489,534197\r
+979858,501616\r
+685893,514935\r
+747477,511661\r
+167214,575367\r
+234140,559696\r
+940238,503122\r
+728969,512609\r
+232083,560102\r
+900971,504694\r
+688801,514772\r
+189664,569402\r
+891022,505104\r
+445689,531996\r
+119570,591871\r
+821453,508118\r
+371084,539600\r
+911745,504251\r
+623655,518600\r
+144361,582486\r
+352442,541775\r
+420726,534367\r
+295298,549387\r
+6530,787777\r
+468397,529976\r
+672336,515696\r
+431861,533289\r
+84228,610150\r
+805376,508857\r
+444409,532117\r
+33833,663511\r
+381850,538396\r
+402931,536157\r
+92901,604930\r
+304825,548004\r
+731917,512452\r
+753734,511344\r
+51894,637373\r
+151578,580103\r
+295075,549421\r
+303590,548183\r
+333594,544123\r
+683952,515042\r
+60090,628880\r
+951420,502692\r
+28335,674991\r
+714940,513349\r
+343858,542826\r
+549279,523586\r
+804571,508887\r
+260653,554881\r
+291399,549966\r
+402342,536213\r
+408889,535550\r
+40328,652524\r
+375856,539061\r
+768907,510590\r
+165993,575715\r
+976327,501755\r
+898500,504795\r
+360404,540830\r
+478714,529095\r
+694144,514472\r
+488726,528258\r
+841380,507226\r
+328012,544839\r
+22389,690868\r
+604053,519852\r
+329514,544641\r
+772965,510390\r
+492798,527927\r
+30125,670983\r
+895603,504906\r
+450785,531539\r
+840237,507276\r
+380711,538522\r
+63577,625673\r
+76801,615157\r
+502694,527123\r
+597706,520257\r
+310484,547206\r
+944468,502959\r
+121283,591152\r
+451131,531507\r
+566499,522367\r
+425373,533918\r
+40240,652665\r
+39130,654392\r
+714926,513355\r
+469219,529903\r
+806929,508783\r
+287970,550487\r
+92189,605332\r
+103841,599094\r
+671839,515725\r
+452048,531421\r
+987837,501323\r
+935192,503321\r
+88585,607450\r
+613883,519216\r
+144551,582413\r
+647359,517155\r
+213902,563816\r
+184120,570789\r
+258126,555322\r
+502546,527130\r
+407655,535678\r
+401528,536306\r
+477490,529193\r
+841085,507237\r
+732831,512408\r
+833000,507595\r
+904694,504542\r
+581435,521348\r
+455545,531110\r
+873558,505829\r
+94916,603796\r
+720176,513068\r
+545034,523891\r
+246348,557409\r
+556452,523079\r
+832015,507634\r
+173663,573564\r
+502634,527125\r
+250732,556611\r
+569786,522139\r
+216919,563178\r
+521815,525623\r
+92304,605270\r
+164446,576167\r
+753413,511364\r
+11410,740712\r
+448845,531712\r
+925072,503725\r
+564888,522477\r
+7062,780812\r
+641155,517535\r
+738878,512100\r
+636204,517828\r
+372540,539436\r
+443162,532237\r
+571192,522042\r
+655350,516680\r
+299741,548735\r
+581914,521307\r
+965471,502156\r
+513441,526277\r
+808682,508700\r
+237589,559034\r
+543300,524025\r
+804712,508889\r
+247511,557192\r
+543486,524008\r
+504383,526992\r
+326529,545039\r
+792493,509458\r
+86033,609017\r
+126554,589005\r
+579379,521481\r
+948026,502823\r
+404777,535969\r
+265767,554022\r
+266876,553840\r
+46631,643714\r
+492397,527958\r
+856106,506581\r
+795757,509305\r
+748946,511584\r
+294694,549480\r
+409781,535463\r
+775887,510253\r
+543747,523991\r
+210592,564536\r
+517119,525990\r
+520253,525751\r
+247926,557124\r
+592141,520626\r
+346580,542492\r
+544969,523902\r
+506501,526817\r
+244520,557738\r
+144745,582349\r
+69274,620858\r
+292620,549784\r
+926027,503687\r
+736320,512225\r
+515528,526113\r
+407549,535688\r
+848089,506927\r
+24141,685711\r
+9224,757964\r
+980684,501586\r
+175259,573121\r
+489160,528216\r
+878970,505604\r
+969546,502002\r
+525207,525365\r
+690461,514675\r
+156510,578551\r
+659778,516426\r
+468739,529945\r
+765252,510770\r
+76703,615230\r
+165151,575959\r
+29779,671736\r
+928865,503569\r
+577538,521605\r
+927555,503618\r
+185377,570477\r
+974756,501809\r
+800130,509093\r
+217016,563153\r
+365709,540216\r
+774508,510320\r
+588716,520851\r
+631673,518104\r
+954076,502590\r
+777828,510161\r
+990659,501222\r
+597799,520254\r
+786905,509727\r
+512547,526348\r
+756449,511212\r
+869787,505988\r
+653747,516779\r
+84623,609900\r
+839698,507295\r
+30159,670909\r
+797275,509234\r
+678136,515373\r
+897144,504851\r
+989554,501263\r
+413292,535106\r
+55297,633667\r
+788650,509637\r
+486748,528417\r
+150724,580377\r
+56434,632490\r
+77207,614869\r
+588631,520859\r
+611619,519367\r
+100006,601055\r
+528924,525093\r
+190225,569257\r
+851155,506789\r
+682593,515114\r
+613043,519275\r
+514673,526183\r
+877634,505655\r
+878905,505602\r
+1926,914951\r
+613245,519259\r
+152481,579816\r
+841774,507203\r
+71060,619442\r
+865335,506175\r
+90244,606469\r
+302156,548388\r
+399059,536557\r
+478465,529113\r
+558601,522925\r
+69132,620966\r
+267663,553700\r
+988276,501310\r
+378354,538787\r
+529909,525014\r
+161733,576968\r
+758541,511109\r
+823425,508024\r
+149821,580667\r
+269258,553438\r
+481152,528891\r
+120871,591322\r
+972322,501901\r
+981350,501567\r
+676129,515483\r
+950860,502717\r
+119000,592114\r
+392252,537272\r
+191618,568919\r
+946699,502874\r
+289555,550247\r
+799322,509139\r
+703886,513942\r
+194812,568143\r
+261823,554685\r
+203052,566221\r
+217330,563093\r
+734748,512313\r
+391759,537328\r
+807052,508777\r
+564467,522510\r
+59186,629748\r
+113447,594545\r
+518063,525916\r
+905944,504492\r
+613922,519213\r
+439093,532607\r
+445946,531981\r
+230530,560399\r
+297887,549007\r
+459029,530797\r
+403692,536075\r
+855118,506616\r
+963127,502245\r
+841711,507208\r
+407411,535699\r
+924729,503735\r
+914823,504132\r
+333725,544101\r
+176345,572832\r
+912507,504225\r
+411273,535308\r
+259774,555036\r
+632853,518038\r
+119723,591801\r
+163902,576321\r
+22691,689944\r
+402427,536212\r
+175769,572988\r
+837260,507402\r
+603432,519893\r
+313679,546767\r
+538165,524394\r
+549026,523608\r
+61083,627945\r
+898345,504798\r
+992556,501153\r
+369999,539727\r
+32847,665404\r
+891292,505088\r
+152715,579732\r
+824104,507997\r
+234057,559711\r
+730507,512532\r
+960529,502340\r
+388395,537687\r
+958170,502437\r
+57105,631806\r
+186025,570311\r
+993043,501133\r
+576770,521664\r
+215319,563513\r
+927342,503628\r
+521353,525666\r
+39563,653705\r
+752516,511408\r
+110755,595770\r
+309749,547305\r
+374379,539224\r
+919184,503952\r
+990652,501226\r
+647780,517135\r
+187177,570017\r
+168938,574877\r
+649558,517023\r
+278126,552016\r
+162039,576868\r
+658512,516499\r
+498115,527486\r
+896583,504868\r
+561170,522740\r
+747772,511647\r
+775093,510294\r
+652081,516882\r
+724905,512824\r
+499707,527365\r
+47388,642755\r
+646668,517204\r
+571700,522007\r
+180430,571747\r
+710015,513617\r
+435522,532941\r
+98137,602041\r
+759176,511070\r
+486124,528467\r
+526942,525236\r
+878921,505604\r
+408313,535602\r
+926980,503640\r
+882353,505459\r
+566887,522345\r
+3326,853312\r
+911981,504248\r
+416309,534800\r
+392991,537199\r
+622829,518651\r
+148647,581055\r
+496483,527624\r
+666314,516044\r
+48562,641293\r
+672618,515684\r
+443676,532187\r
+274065,552661\r
+265386,554079\r
+347668,542358\r
+31816,667448\r
+181575,571446\r
+961289,502320\r
+365689,540214\r
+987950,501317\r
+932299,503440\r
+27388,677243\r
+746701,511701\r
+492258,527969\r
+147823,581323\r
+57918,630985\r
+838849,507333\r
+678038,515375\r
+27852,676130\r
+850241,506828\r
+818403,508253\r
+131717,587014\r
+850216,506834\r
+904848,504529\r
+189758,569380\r
+392845,537217\r
+470876,529761\r
+925353,503711\r
+285431,550877\r
+454098,531234\r
+823910,508003\r
+318493,546112\r
+766067,510730\r
+261277,554775\r
+421530,534289\r
+694130,514478\r
+120439,591498\r
+213308,563949\r
+854063,506662\r
+365255,540263\r
+165437,575872\r
+662240,516281\r
+289970,550181\r
+847977,506933\r
+546083,523816\r
+413252,535113\r
+975829,501767\r
+361540,540701\r
+235522,559435\r
+224643,561577\r
+736350,512229\r
+328303,544808\r
+35022,661330\r
+307838,547578\r
+474366,529458\r
+873755,505819\r
+73978,617220\r
+827387,507845\r
+670830,515791\r
+326511,545034\r
+309909,547285\r
+400970,536363\r
+884827,505352\r
+718307,513175\r
+28462,674699\r
+599384,520150\r
+253565,556111\r
+284009,551093\r
+343403,542876\r
+446557,531921\r
+992372,501160\r
+961601,502308\r
+696629,514342\r
+919537,503945\r
+894709,504944\r
+892201,505051\r
+358160,541097\r
+448503,531745\r
+832156,507636\r
+920045,503924\r
+926137,503675\r
+416754,534757\r
+254422,555966\r
+92498,605151\r
+826833,507873\r
+660716,516371\r
+689335,514746\r
+160045,577467\r
+814642,508425\r
+969939,501993\r
+242856,558047\r
+76302,615517\r
+472083,529653\r
+587101,520964\r
+99066,601543\r
+498005,527503\r
+709800,513624\r
+708000,513716\r
+20171,698134\r
+285020,550936\r
+266564,553891\r
+981563,501557\r
+846502,506991\r
+334,1190800\r
+209268,564829\r
+9844,752610\r
+996519,501007\r
+410059,535426\r
+432931,533188\r
+848012,506929\r
+966803,502110\r
+983434,501486\r
+160700,577267\r
+504374,526989\r
+832061,507640\r
+392825,537214\r
+443842,532165\r
+440352,532492\r
+745125,511776\r
+13718,726392\r
+661753,516312\r
+70500,619875\r
+436952,532814\r
+424724,533973\r
+21954,692224\r
+262490,554567\r
+716622,513264\r
+907584,504425\r
+60086,628882\r
+837123,507412\r
+971345,501940\r
+947162,502855\r
+139920,584021\r
+68330,621624\r
+666452,516038\r
+731446,512481\r
+953350,502619\r
+183157,571042\r
+845400,507045\r
+651548,516910\r
+20399,697344\r
+861779,506331\r
+629771,518229\r
+801706,509026\r
+189207,569512\r
+737501,512168\r
+719272,513115\r
+479285,529045\r
+136046,585401\r
+896746,504860\r
+891735,505067\r
+684771,514999\r
+865309,506184\r
+379066,538702\r
+503117,527090\r
+621780,518717\r
+209518,564775\r
+677135,515423\r
+987500,501340\r
+197049,567613\r
+329315,544673\r
+236756,559196\r
+357092,541226\r
+520440,525733\r
+213471,563911\r
+956852,502490\r
+702223,514032\r
+404943,535955\r
+178880,572152\r
+689477,514734\r
+691351,514630\r
+866669,506128\r
+370561,539656\r
+739805,512051\r
+71060,619441\r
+624861,518534\r
+261660,554714\r
+366137,540160\r
+166054,575698\r
+601878,519990\r
+153445,579501\r
+279899,551729\r
+379166,538691\r
+423209,534125\r
+675310,515526\r
+145641,582050\r
+691353,514627\r
+917468,504026\r
+284778,550976\r
+81040,612235\r
+161699,576978\r
+616394,519057\r
+767490,510661\r
+156896,578431\r
+427408,533714\r
+254849,555884\r
+737217,512182\r
+897133,504851\r
+203815,566051\r
+270822,553189\r
+135854,585475\r
+778805,510111\r
+784373,509847\r
+305426,547921\r
+733418,512375\r
+732087,512448\r
+540668,524215\r
+702898,513996\r
+628057,518328\r
+640280,517587\r
+422405,534204\r
+10604,746569\r
+746038,511733\r
+839808,507293\r
+457417,530938\r
+479030,529064\r
+341758,543090\r
+620223,518824\r
+251661,556451\r
+561790,522696\r
+497733,527521\r
+724201,512863\r
+489217,528217\r
+415623,534867\r
+624610,518548\r
+847541,506953\r
+432295,533249\r
+400391,536421\r
+961158,502319\r
+139173,584284\r
+421225,534315\r
+579083,521501\r
+74274,617000\r
+701142,514087\r
+374465,539219\r
+217814,562985\r
+358972,540995\r
+88629,607424\r
+288597,550389\r
+285819,550812\r
+538400,524385\r
+809930,508645\r
+738326,512126\r
+955461,502535\r
+163829,576343\r
+826475,507891\r
+376488,538987\r
+102234,599905\r
+114650,594002\r
+52815,636341\r
+434037,533082\r
+804744,508880\r
+98385,601905\r
+856620,506559\r
+220057,562517\r
+844734,507078\r
+150677,580387\r
+558697,522917\r
+621751,518719\r
+207067,565321\r
+135297,585677\r
+932968,503404\r
+604456,519822\r
+579728,521462\r
+244138,557813\r
+706487,513800\r
+711627,513523\r
+853833,506674\r
+497220,527562\r
+59428,629511\r
+564845,522486\r
+623621,518603\r
+242689,558077\r
+125091,589591\r
+363819,540432\r
+686453,514901\r
+656813,516594\r
+489901,528155\r
+386380,537905\r
+542819,524052\r
+243987,557841\r
+693412,514514\r
+488484,528271\r
+896331,504881\r
+336730,543721\r
+728298,512647\r
+604215,519840\r
+153729,579413\r
+595687,520398\r
+540360,524240\r
+245779,557511\r
+924873,503730\r
+509628,526577\r
+528523,525122\r
+3509,847707\r
+522756,525555\r
+895447,504922\r
+44840,646067\r
+45860,644715\r
+463487,530404\r
+398164,536654\r
+894483,504959\r
+619415,518874\r
+966306,502129\r
+990922,501212\r
+835756,507474\r
+548881,523618\r
+453578,531282\r
+474993,529410\r
+80085,612879\r
+737091,512193\r
+50789,638638\r
+979768,501620\r
+792018,509483\r
+665001,516122\r
+86552,608694\r
+462772,530469\r
+589233,520821\r
+891694,505072\r
+592605,520594\r
+209645,564741\r
+42531,649269\r
+554376,523226\r
+803814,508929\r
+334157,544042\r
+175836,572970\r
+868379,506051\r
+658166,516520\r
+278203,551995\r
+966198,502126\r
+627162,518387\r
+296774,549165\r
+311803,547027\r
+843797,507118\r
+702304,514032\r
+563875,522553\r
+33103,664910\r
+191932,568841\r
+543514,524006\r
+506835,526794\r
+868368,506052\r
+847025,506971\r
+678623,515342\r
+876139,505726\r
+571997,521984\r
+598632,520198\r
+213590,563892\r
+625404,518497\r
+726508,512738\r
+689426,514738\r
+332495,544264\r
+411366,535302\r
+242546,558110\r
+315209,546555\r
+797544,509219\r
+93889,604371\r
+858879,506454\r
+124906,589666\r
+449072,531693\r
+235960,559345\r
+642403,517454\r
+720567,513047\r
+705534,513858\r
+603692,519870\r
+488137,528302\r
+157370,578285\r
+63515,625730\r
+666326,516041\r
+619226,518883\r
+443613,532186\r
+597717,520257\r
+96225,603069\r
+86940,608450\r
+40725,651929\r
+460976,530625\r
+268875,553508\r
+270671,553214\r
+363254,540500\r
+384248,538137\r
+762889,510892\r
+377941,538833\r
+278878,551890\r
+176615,572755\r
+860008,506412\r
+944392,502967\r
+608395,519571\r
+225283,561450\r
+45095,645728\r
+333798,544090\r
+625733,518476\r
+995584,501037\r
+506135,526853\r
+238050,558952\r
+557943,522972\r
+530978,524938\r
+634244,517949\r
+177168,572616\r
+85200,609541\r
+953043,502630\r
+523661,525484\r
+999295,500902\r
+840803,507246\r
+961490,502312\r
+471747,529685\r
+380705,538523\r
+911180,504275\r
+334149,544046\r
+478992,529065\r
+325789,545133\r
+335884,543826\r
+426976,533760\r
+749007,511582\r
+667067,516000\r
+607586,519623\r
+674054,515599\r
+188534,569675\r
+565185,522464\r
+172090,573988\r
+87592,608052\r
+907432,504424\r
+8912,760841\r
+928318,503590\r
+757917,511138\r
+718693,513153\r
+315141,546566\r
+728326,512645\r
+353492,541647\r
+638429,517695\r
+628892,518280\r
+877286,505672\r
+620895,518778\r
+385878,537959\r
+423311,534113\r
+633501,517997\r
+884833,505360\r
+883402,505416\r
+999665,500894\r
+708395,513697\r
+548142,523667\r
+756491,511205\r
+987352,501340\r
+766520,510705\r
+591775,520647\r
+833758,507563\r
+843890,507108\r
+925551,503698\r
+74816,616598\r
+646942,517187\r
+354923,541481\r
+256291,555638\r
+634470,517942\r
+930904,503494\r
+134221,586071\r
+282663,551304\r
+986070,501394\r
+123636,590176\r
+123678,590164\r
+481717,528841\r
+423076,534137\r
+866246,506145\r
+93313,604697\r
+783632,509880\r
+317066,546304\r
+502977,527103\r
+141272,583545\r
+71708,618938\r
+617748,518975\r
+581190,521362\r
+193824,568382\r
+682368,515131\r
+352956,541712\r
+351375,541905\r
+505362,526909\r
+905165,504518\r
+128645,588188\r
+267143,553787\r
+158409,577965\r
+482776,528754\r
+628896,518282\r
+485233,528547\r
+563606,522574\r
+111001,595655\r
+115920,593445\r
+365510,540237\r
+959724,502374\r
+938763,503184\r
+930044,503520\r
+970959,501956\r
+913658,504176\r
+68117,621790\r
+989729,501253\r
+567697,522288\r
+820427,508163\r
+54236,634794\r
+291557,549938\r
+124961,589646\r
+403177,536130\r
+405421,535899\r
+410233,535417\r
+815111,508403\r
+213176,563974\r
+83099,610879\r
+998588,500934\r
+513640,526263\r
+129817,587733\r
+1820,921851\r
+287584,550539\r
+299160,548820\r
+860621,506386\r
+529258,525059\r
+586297,521017\r
+953406,502616\r
+441234,532410\r
+986217,501386\r
+781938,509957\r
+461247,530595\r
+735424,512277\r
+146623,581722\r
+839838,507288\r
+510667,526494\r
+935085,503327\r
+737523,512167\r
+303455,548204\r
+992779,501145\r
+60240,628739\r
+939095,503174\r
+794368,509370\r
+501825,527189\r
+459028,530798\r
+884641,505363\r
+512287,526364\r
+835165,507499\r
+307723,547590\r
+160587,577304\r
+735043,512300\r
+493289,527887\r
+110717,595785\r
+306480,547772\r
+318593,546089\r
+179810,571911\r
+200531,566799\r
+314999,546580\r
+197020,567622\r
+301465,548487\r
+237808,559000\r
+131944,586923\r
+882527,505449\r
+468117,530003\r
+711319,513541\r
+156240,578628\r
+965452,502162\r
+992756,501148\r
+437959,532715\r
+739938,512046\r
+614249,519196\r
+391496,537356\r
+62746,626418\r
+688215,514806\r
+75501,616091\r
+883573,505412\r
+558824,522910\r
+759371,511061\r
+173913,573489\r
+891351,505089\r
+727464,512693\r
+164833,576051\r
+812317,508529\r
+540320,524243\r
+698061,514257\r
+69149,620952\r
+471673,529694\r
+159092,577753\r
+428134,533653\r
+89997,606608\r
+711061,513557\r
+779403,510081\r
+203327,566155\r
+798176,509187\r
+667688,515963\r
+636120,517833\r
+137410,584913\r
+217615,563034\r
+556887,523038\r
+667229,515991\r
+672276,515708\r
+325361,545187\r
+172115,573985\r
+13846,725685
\ No newline at end of file
-USING: project-euler.203 tools.test ;
+USING: project-euler.203 project-euler.203.private tools.test ;
IN: project-euler.203.tests
[ 105 ] [ 8 solve ] unit-test
-[ 34029210557338 ] [ 51 solve ] unit-test
+[ 34029210557338 ] [ euler203 ] unit-test
+! Copyright (c) 2008 Eric Mertens.
+! See http://factorcode.org/license.txt for BSD license.
USING: fry kernel math math.primes.factors sequences sets ;
IN: project-euler.203
-: iterate ( n initial quot -- results ) swapd '[ @ dup ] replicate nip ; inline
-: (generate) ( seq -- seq ) [ 0 prefix ] [ 0 suffix ] bi [ + ] 2map ;
-: generate ( n -- seq ) 1- { 1 } [ (generate) ] iterate concat prune ;
-: squarefree ( n -- ? ) factors duplicates empty? ;
-: solve ( n -- n ) generate [ squarefree ] filter sum ;
-: euler203 ( -- n ) 51 solve ;
+! http://projecteuler.net/index.php?section=problems&id=203
+
+! DESCRIPTION
+! -----------
+
+! The binomial coefficients nCk can be arranged in triangular form, Pascal's
+! triangle, like this:
+
+! 1
+! 1 1
+! 1 2 1
+! 1 3 3 1
+! 1 4 6 4 1
+! 1 5 10 10 5 1
+! 1 6 15 20 15 6 1
+! 1 7 21 35 35 21 7 1
+! .........
+
+! It can be seen that the first eight rows of Pascal's triangle contain twelve
+! distinct numbers: 1, 2, 3, 4, 5, 6, 7, 10, 15, 20, 21 and 35.
+
+! A positive integer n is called squarefree if no square of a prime divides n.
+! Of the twelve distinct numbers in the first eight rows of Pascal's triangle,
+! all except 4 and 20 are squarefree. The sum of the distinct squarefree numbers
+! in the first eight rows is 105.
+
+! Find the sum of the distinct squarefree numbers in the first 51 rows of
+! Pascal's triangle.
+
+
+! SOLUTION
+! --------
+
+<PRIVATE
+
+: iterate ( n initial quot -- results )
+ swapd '[ @ dup ] replicate nip ; inline
+
+: (generate) ( seq -- seq )
+ [ 0 prefix ] [ 0 suffix ] bi [ + ] 2map ;
+
+: generate ( n -- seq )
+ 1- { 1 } [ (generate) ] iterate concat prune ;
+
+: squarefree ( n -- ? )
+ factors all-unique? ;
+
+: solve ( n -- n )
+ generate [ squarefree ] filter sum ;
+
+PRIVATE>
+
+: euler203 ( -- n )
+ 51 solve ;
+
+! [ euler203 ] 100 ave-time
+! 12 ms ave run time - 1.6 SD (100 trials)
+
+MAIN: euler203
! -----------
! Consider the problem of building a wall out of 2x1 and 3x1 bricks
-! (horizontalvertical dimensions) such that, for extra strength, the gaps
+! (horizontal x vertical dimensions) such that, for extra strength, the gaps
! between horizontally-adjacent bricks never line up in consecutive layers,
! i.e. never form a "running crack".
project-euler.052 project-euler.053 project-euler.055 project-euler.056
project-euler.059 project-euler.067 project-euler.071 project-euler.073
project-euler.075 project-euler.076 project-euler.079 project-euler.092
- project-euler.097 project-euler.100 project-euler.116 project-euler.117
- project-euler.134 project-euler.148 project-euler.150 project-euler.151
- project-euler.164 project-euler.169 project-euler.173 project-euler.175
- project-euler.186 project-euler.190 project-euler.215 ;
+ project-euler.097 project-euler.099 project-euler.100 project-euler.116
+ project-euler.117 project-euler.134 project-euler.148 project-euler.150
+ project-euler.151 project-euler.164 project-euler.169 project-euler.173
+ project-euler.175 project-euler.186 project-euler.190 project-euler.203
+ project-euler.215 ;
IN: project-euler
<PRIVATE
: $divider ( -- )
[
<gadget>
- T{ gradient f
- {
- T{ rgba f 0.25 0.25 0.25 1.0 }
- T{ rgba f 1.0 1.0 1.0 0.0 }
- }
- } >>interior
+ {
+ T{ rgba f 0.25 0.25 0.25 1.0 }
+ T{ rgba f 1.0 1.0 1.0 0.0 }
+ } <gradient> >>interior
{ 800 10 } >>dim
{ 1 0 } >>orientation
gadget.
] ($block) ;
: page-theme ( gadget -- )
- T{ gradient f { T{ rgba f 0.8 0.8 1.0 1.0 } T{ rgba f 0.8 1.0 1.0 1.0 } } }
+ { T{ rgba f 0.8 0.8 1.0 1.0 } T{ rgba f 0.8 1.0 1.0 1.0 } } <gradient>
>>interior drop ;
: <page> ( list -- gadget )
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-: draw-node ( node -- ) pos>> { -5 -5 } v+ dup { 10 10 } v+ gl-rect ;
+: draw-node ( node -- ) pos>> { -5 -5 } v+ [ { 10 10 } gl-rect ] with-translation ;
: draw-spring ( spring -- )
[ node-a>> pos>> ] [ node-b>> pos>> ] bi gl-line ;
+++ /dev/null
-Doug Coleman
+++ /dev/null
-USING: kernel state-tables tools.test ;
-IN: state-tables.tests
-
-: test-table
- <table>
- "a" "c" "z" <entry> over set-entry
- "a" "o" "y" <entry> over set-entry
- "a" "l" "x" <entry> over set-entry
- "b" "o" "y" <entry> over set-entry
- "b" "l" "x" <entry> over set-entry
- "b" "s" "u" <entry> over set-entry ;
-
-[
- T{
- table
- f
- H{
- { "a" H{ { "l" "x" } { "c" "z" } { "o" "y" } } }
- { "b" H{ { "l" "x" } { "s" "u" } { "o" "y" } } }
- }
- H{ { "l" t } { "s" t } { "c" t } { "o" t } }
- f
- H{ }
- }
-] [ test-table ] unit-test
-
-[ "x" t ] [ "a" "l" test-table get-entry ] unit-test
-[ "har" t ] [
- "a" "z" "har" <entry> test-table [ set-entry ] keep
- >r "a" "z" r> get-entry
-] unit-test
-
-: vector-test-table
- <vector-table>
- "a" "c" "z" <entry> over add-entry
- "a" "c" "r" <entry> over add-entry
- "a" "o" "y" <entry> over add-entry
- "a" "l" "x" <entry> over add-entry
- "b" "o" "y" <entry> over add-entry
- "b" "l" "x" <entry> over add-entry
- "b" "s" "u" <entry> over add-entry ;
-
-[
-T{ vector-table f
- H{
- { "a"
- H{ { "l" "x" } { "c" V{ "z" "r" } } { "o" "y" } } }
- { "b"
- H{ { "l" "x" } { "s" "u" } { "o" "y" } } }
- }
- H{ { "l" t } { "s" t } { "c" t } { "o" t } }
- f
- H{ }
-}
-] [ vector-test-table ] unit-test
-
+++ /dev/null
-! Copyright (C) 2008 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel namespaces make sequences vectors assocs accessors ;
-IN: state-tables
-
-TUPLE: table rows columns start-state final-states ;
-TUPLE: entry row-key column-key value ;
-
-GENERIC: add-entry ( entry table -- )
-
-: make-table ( class -- obj )
- new
- H{ } clone >>rows
- H{ } clone >>columns
- H{ } clone >>final-states ;
-
-: <table> ( -- obj )
- table make-table ;
-
-C: <entry> entry
-
-: (add-row) ( row-key table -- row )
- 2dup rows>> at* [
- 2nip
- ] [
- drop H{ } clone [ -rot rows>> set-at ] keep
- ] if ;
-
-: add-row ( row-key table -- )
- (add-row) drop ;
-
-: add-column ( column-key table -- )
- t -rot columns>> set-at ;
-
-: set-row ( row row-key table -- )
- rows>> set-at ;
-
-: lookup-row ( row-key table -- row/f ? )
- rows>> at* ;
-
-: row-exists? ( row-key table -- ? )
- lookup-row nip ;
-
-: lookup-column ( column-key table -- column/f ? )
- columns>> at* ;
-
-: column-exists? ( column-key table -- ? )
- lookup-column nip ;
-
-ERROR: no-row key ;
-ERROR: no-column key ;
-
-: get-row ( row-key table -- row )
- dupd lookup-row [
- nip
- ] [
- drop no-row
- ] if ;
-
-: get-column ( column-key table -- column )
- dupd lookup-column [
- nip
- ] [
- drop no-column
- ] if ;
-
-: get-entry ( row-key column-key table -- obj ? )
- swapd lookup-row [
- at*
- ] [
- 2drop f f
- ] if ;
-
-: (set-entry) ( entry table -- value column-key row )
- [ >r column-key>> r> add-column ] 2keep
- dupd >r row-key>> r> (add-row)
- >r [ value>> ] keep column-key>> r> ;
-
-: set-entry ( entry table -- )
- (set-entry) set-at ;
-
-: delete-entry ( entry table -- )
- >r [ column-key>> ] [ row-key>> ] bi r>
- lookup-row [ delete-at ] [ 2drop ] if ;
-
-: swap-rows ( row-key1 row-key2 table -- )
- [ tuck get-row >r get-row r> ] 3keep
- >r >r rot r> r> [ set-row ] keep set-row ;
-
-: member?* ( obj obj -- bool )
- 2dup = [ 2drop t ] [ member? ] if ;
-
-: find-by-column ( column-key data table -- seq )
- swapd 2dup lookup-column 2drop
- [
- rows>> [
- pick swap at* [
- >r pick r> member?* [ , ] [ drop ] if
- ] [
- 2drop
- ] if
- ] assoc-each
- ] { } make 2nip ;
-
-
-TUPLE: vector-table < table ;
-: <vector-table> ( -- obj )
- vector-table make-table ;
-
-: add-hash-vector ( value key hash -- )
- 2dup at* [
- dup vector? [
- 2nip push
- ] [
- V{ } clone [ push ] keep
- -rot >r >r [ push ] keep r> r> set-at
- ] if
- ] [
- drop set-at
- ] if ;
-
-M: vector-table add-entry ( entry table -- )
- (set-entry) add-hash-vector ;
+++ /dev/null
-
-USING: kernel sequences math math.order
- ui.gadgets ui.gadgets.tracks ui.gestures
- bake.fry accessors ;
-
-IN: ui.gadgets.tiling
-
-TUPLE: tiling < track gadgets tiles first focused ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: init-tiling ( tiling -- tiling )
- init-track
- { 1 0 } >>orientation
- V{ } clone >>gadgets
- 2 >>tiles
- 0 >>first
- 0 >>focused ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: <tiling> ( -- gadget ) tiling new init-tiling ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: bounded-subseq ( seq a b -- seq )
- [ 0 max ] dip
- pick length [ min ] curry bi@
- rot
- subseq ;
-
-: tiling-gadgets-to-map ( tiling -- gadgets )
- [ gadgets>> ]
- [ first>> ]
- [ [ first>> ] [ tiles>> ] bi + ]
- tri
- bounded-subseq ;
-
-: tiling-map-gadgets ( tiling -- tiling )
- dup clear-track
- dup tiling-gadgets-to-map [ 1 track-add ] each ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: tiling-add ( tiling gadget -- tiling )
- over gadgets>> push
- tiling-map-gadgets ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: first-gadget ( tiling -- index ) drop 0 ;
-
-: last-gadget ( tiling -- index ) gadgets>> length 1 - ;
-
-: first-viewable ( tiling -- index ) first>> ;
-
-: last-viewable ( tiling -- index ) [ first>> ] [ tiles>> ] bi + 1 - ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: make-focused-mapped ( tiling -- tiling )
-
- dup [ focused>> ] [ first>> ] bi <
- [ dup first>> 1 - >>first ]
- [ ]
- if
-
- dup [ last-viewable ] [ focused>> ] bi <
- [ dup first>> 1 + >>first ]
- [ ]
- if ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: check-focused-bounds ( tiling -- tiling )
- dup focused>> 0 max over gadgets>> length 1 - min >>focused ;
-
-: focus-prev ( tiling -- tiling )
- dup focused>> 1 - >>focused
- check-focused-bounds
- make-focused-mapped
- tiling-map-gadgets
- dup request-focus ;
-
-: focus-next ( tiling -- tiling )
- dup focused>> 1 + >>focused
- check-focused-bounds
- make-focused-mapped
- tiling-map-gadgets
- dup request-focus ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: exchanged! ( seq a b -- )
- [ 0 max ] bi@
- pick length 1 - '[ _ min ] bi@
- rot exchange ;
-
-: move-prev ( tiling -- tiling )
- dup [ gadgets>> ] [ focused>> 1 - ] [ focused>> ] tri exchanged!
- focus-prev ;
-
-: move-next ( tiling -- tiling )
- dup [ gadgets>> ] [ focused>> ] [ focused>> 1 + ] tri exchanged!
- focus-next ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: add-tile ( tiling -- tiling )
- dup tiles>> 1 + >>tiles
- tiling-map-gadgets ;
-
-: del-tile ( tiling -- tiling )
- dup tiles>> 1 - 1 max >>tiles
- tiling-map-gadgets ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-M: tiling focusable-child* ( tiling -- child/t )
- [ focused>> ] [ gadgets>> ] bi nth ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-TUPLE: tiling-shelf < tiling ;
-TUPLE: tiling-pile < tiling ;
-
-: <tiling-shelf> ( -- gadget )
- tiling-shelf new init-tiling { 1 0 } >>orientation ;
-
-: <tiling-pile> ( -- gadget )
- tiling-pile new init-tiling { 0 1 } >>orientation ;
-
-tiling-shelf
- H{
- { T{ key-down f { A+ } "LEFT" } [ focus-prev drop ] }
- { T{ key-down f { A+ } "RIGHT" } [ focus-next drop ] }
- { T{ key-down f { S+ A+ } "LEFT" } [ move-prev drop ] }
- { T{ key-down f { S+ A+ } "RIGHT" } [ move-next drop ] }
- { T{ key-down f { C+ } "[" } [ del-tile drop ] }
- { T{ key-down f { C+ } "]" } [ add-tile drop ] }
- }
-set-gestures
-
-tiling-pile
- H{
- { T{ key-down f { A+ } "UP" } [ focus-prev drop ] }
- { T{ key-down f { A+ } "DOWN" } [ focus-next drop ] }
- { T{ key-down f { S+ A+ } "UP" } [ move-prev drop ] }
- { T{ key-down f { S+ A+ } "DOWN" } [ move-next drop ] }
- { T{ key-down f { C+ } "[" } [ del-tile drop ] }
- { T{ key-down f { C+ } "]" } [ add-tile drop ] }
- }
-set-gestures
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors colors arrays kernel sequences math byte-arrays
+namespaces cap graphics.bitmap
+ui.gadgets ui.gadgets.packs ui.gadgets.borders ui.gadgets.grids
+ui.gadgets.grid-lines ui.gadgets.labels ui.gadgets.buttons
+ui.render ui opengl opengl.gl ;
+IN: ui.render.test
+
+SINGLETON: line-test
+
+M: line-test draw-interior
+ 2drop { 0 0 } { 0 10 } gl-line ;
+
+: <line-gadget> ( -- gadget )
+ <gadget>
+ line-test >>interior
+ { 1 10 } >>dim ;
+
+TUPLE: ui-render-test < pack { first-time? initial: t } ;
+
+: message-window ( text -- )
+ <label> "Message" open-window ;
+
+: twiddle ( bytes -- bytes )
+ #! On Windows, white is { 253 253 253 } ?
+ [ dup 253 = [ 2 + ] when ] map ;
+
+: check-rendering ( gadget -- )
+ gl-screenshot twiddle
+ "resource:extra/ui/render/test/reference.bmp" load-bitmap array>>
+ = "perfect" "needs work" ? "Your UI rendering is " prepend
+ message-window ;
+
+M: ui-render-test draw-gadget*
+ [ call-next-method ] [
+ dup first-time?>> [
+ dup check-rendering
+ f >>first-time?
+ ] when
+ drop
+ ] bi ;
+
+: <ui-render-test> ( -- gadget )
+ \ ui-render-test new-gadget
+ { 1 0 } >>orientation
+ <gadget>
+ black <solid> >>interior
+ { 98 98 } >>dim
+ 1 <border> add-gadget
+ <gadget>
+ gray <solid> >>boundary
+ { 94 94 } >>dim
+ 3 <border>
+ red <solid> >>boundary
+ add-gadget
+ <line-gadget> <line-gadget> <line-gadget> 3array
+ <line-gadget> <line-gadget> <line-gadget> 3array
+ <line-gadget> <line-gadget> <line-gadget> 3array
+ 3array <grid>
+ { 5 5 } >>gap
+ blue <grid-lines> >>boundary
+ add-gadget
+ <gadget>
+ { 14 14 } >>dim
+ black <checkmark-paint> >>interior
+ black <solid> >>boundary
+ 4 <border>
+ add-gadget ;
+
+: ui-render-test ( -- )
+ <ui-render-test> "Test" open-window ;
+
+MAIN: ui-render-test
: git-pull-master ( -- )
image parent-directory
[
- { "git" "pull" "git://factorcode.org/git/factor.git" "master" }
+ { "git" "pull" "http://factorcode.org/git/factor.git" "master" }
run-command
]
with-directory ;
--- /dev/null
+Slava Pestov
--- /dev/null
+Slides from a talk at VPRI by Slava Pestov, October 2008
{ "search" [ 1 v-min-length 50 v-max-length v-one-line ] }
} validate-params
- help-dir set-current-directory
-
- "search" value article-apropos "articles" set-value
- "search" value word-apropos "words" set-value
- "search" value vocab-apropos "vocabs" set-value
+ help-dir [
+ "search" value article-apropos "articles" set-value
+ "search" value word-apropos "words" set-value
+ "search" value vocab-apropos "vocabs" set-value
+ ] with-directory
{ help-webapp "search" } <chloe-content>
] >>submit ;
<t:form t:action="$help-webapp/search">
<t:field t:name="search" />
- <button>Search</button>
+ <button type="submit">Search</button>
</t:form>
<t:if t:value="articles">
</tr>
</table>
- <p> <button>Submit</button> </p>
+ <p> <button type="submit">Submit</button> </p>
</t:form>
</t:chloe>
</tr>
</table>
- <p> <button>Done</button> </p>
+ <p> <button type="submit">Done</button> </p>
</t:form>
<th class="field-label big-field-label">Capabilities:</th>
<td>
<t:each t:name="capabilities">
- <li><t:checkbox t:name="@value" t:label="@value" /><br/>
+ <t:checkbox t:name="@value" t:label="@value" /><br/>
</t:each>
</td>
</tr>
<t:form t:action="$wee-url">
<p>Shorten URL: <t:field t:name="url" t:size="40" /></p>
- <button>Shorten</button>
+ <button type="submit">Shorten</button>
</t:form>
</t:chloe>
</p>
<p>
- <button>Save</button>
+ <button type="submit">Save</button>
</p>
</t:form>
</tr>
</table>
- <button>View</button>
+ <button type="submit">View</button>
</t:form>
</t:chloe>
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-
-USING: kernel namespaces arrays sequences math x11.xlib
- mortar slot-accessors x ;
-
-IN: x.font
-
-SYMBOL: <font>
-
-<font> { "dpy" "name" "id" "struct" } accessors define-independent-class
-
-<font> "create" !( name <font> -- font ) [
-new-empty swap >>name dpy get >>dpy
-dpy get $ptr over $name XLoadQueryFont >>struct
-dup $struct XFontStruct-fid >>id
-] add-class-method
-
-<font> {
-
-"ascent" !( font -- ascent ) [ $struct XFontStruct-ascent ]
-
-"descent" !( font -- ascent ) [ $struct XFontStruct-descent ]
-
-"height" !( font -- ascent ) [ dup <- ascent swap <- descent + ]
-
-"text-width" !( font string -- width ) [ >r $struct r> dup length XTextWidth ]
-
-} add-methods
\ No newline at end of file
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-
-USING: kernel namespaces arrays x11.xlib mortar mortar.sugar
- slot-accessors x x.font ;
-
-IN: x.gc
-
-SYMBOL: <gc>
-
-<gc> { "dpy" "ptr" "font" } accessors define-independent-class
-
-<gc> "create" !( <gc> -- gc ) [
-new-empty dpy get >>dpy
-dpy get $ptr dpy get $default-root $id 0 f XCreateGC >>ptr
-"6x13" <font> new* >>font
-] add-class-method
-
-<gc> {
-
-"set-subwindow-mode" !( gc mode -- gc )
- [ >r dup $dpy $ptr over $ptr r> XSetSubwindowMode drop ]
-
-"set-function" !( gc function -- gc )
- [ >r dup $dpy $ptr over $ptr r> XSetFunction drop ]
-
-"set-foreground" !( gc foreground -- gc )
- [ >r dup $dpy $ptr over $ptr r> lookup-color XSetForeground drop ]
-
-} add-methods
\ No newline at end of file
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-USING: kernel strings assocs sequences math ;
-
-IN: x.keysym-table
-
-: keysym-table ( -- table )
-H{ { HEX: FF08 "BACKSPACE" }
- { HEX: FF09 "TAB" }
- { HEX: FF0D "RETURN" }
- { HEX: FF8D "ENTER" }
- { HEX: FF1B "ESCAPE" }
- { HEX: FFFF "DELETE" }
- { HEX: FF50 "HOME" }
- { HEX: FF51 "LEFT" }
- { HEX: FF52 "UP" }
- { HEX: FF53 "RIGHT" }
- { HEX: FF54 "DOWN" }
- { HEX: FF55 "PAGE-UP" }
- { HEX: FF56 "PAGE-DOWN" }
- { HEX: FF57 "END" }
- { HEX: FF58 "BEGIN" }
- { HEX: FFBE "F1" }
- { HEX: FFBF "F2" }
- { HEX: FFC0 "F3" }
- { HEX: FFC1 "F4" }
- { HEX: FFC2 "F5" }
- { HEX: FFC3 "F6" }
- { HEX: FFC4 "F7" }
- { HEX: FFC5 "F8" }
- { HEX: FFC6 "F9" }
- { HEX: FFC7 "F10" }
- { HEX: FFC8 "F11" }
- { HEX: FFC9 "F12" }
- { HEX: FFE1 "LEFT-SHIFT" }
- { HEX: FFE2 "RIGHT-SHIFT" }
- { HEX: FFE3 "LEFT-CONTROL" }
- { HEX: FFE4 "RIGHT-CONTROL" }
- { HEX: FFE5 "CAPSLOCK" }
- { HEX: FFE9 "LEFT-ALT" }
- { HEX: FFEA "RIGHT-ALT" }
-} ;
-
-: keysym>name ( keysym -- name )
-dup keysym-table at dup [ nip ] [ drop 1string ] if ;
-
-: name>keysym ( name -- keysym ) keysym-table value-at ;
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-
-USING: kernel arrays math.vectors mortar mortar.sugar x.gc slot-accessors geom.pos ;
-
-IN: x.pen
-
-SYMBOL: <pen>
-
-<pen> <pos> { "window" "gc" } accessors define-simple-class
-
-<pen> "create" !( window <pen> -- pen )
-[ new-empty swap >>window <gc> new* >>gc 0 0 2array >>pos ]
-add-class-method
-
-<pen> {
-
-"line-to" ! ( pen point -- pen )
- [ 2dup >r dup $window swap dup $gc swap $pos r> <---- draw-line >>pos ]
-
-"line-by" ! ( pen offset -- pen )
- [ 2dup >r dup $window swap dup $gc swap $pos dup r> v+ <---- draw-line
- <-- move-by ]
-
-"draw-string" ! ( pen string -- pen )
- [ >r dup dup $window swap dup $gc swap $pos r> <---- draw-string ]
-
-} add-methods
\ No newline at end of file
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-
-USING: kernel combinators math x11.xlib
- mortar mortar.sugar slot-accessors x.gc x.widgets.label ;
-
-IN: x.widgets.button
-
-SYMBOL: <button>
-
-<button>
- <label>
- { "action-1" "action-2" "action-3" } accessors
-define-simple-class
-
-<button> "create" !( <button> -- button ) [
-new-empty
-<gc> new* >>gc ExposureMask ButtonPressMask bitor >>mask <- init-widget
-] add-class-method
-
-<button> "handle-button-press" !( event button -- ) [
-{ { [ over XButtonEvent-button Button1 = ] [ nip $action-1 call ] }
- { [ over XButtonEvent-button Button2 = ] [ nip $action-2 call ] }
- { [ over XButtonEvent-button Button3 = ] [ nip $action-3 call ] } }
-cond
-] add-method
\ No newline at end of file
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-
-USING: kernel strings arrays sequences sequences.lib math x11.xlib
- mortar mortar.sugar slot-accessors x x.pen x.widgets ;
-
-IN: x.widgets.keymenu
-
-SYMBOL: <keymenu>
-
-<keymenu> <widget> { "items" "pen" } accessors define-simple-class
-
-<keymenu> "create" !( <keymenu> -- keymenu )
- [ new-empty <- keymenu-init ]
-add-class-method
-
-: numbers-and-letters ( -- seq )
-"1234567890abcdefghijklmnopqrstuvwxyz" [ 1string ] { } map-as ;
-
-<keymenu> {
-
-"keymenu-init" !( keymenu -- keymenu ) [
- dup <pen> new* >>pen
- ExposureMask KeyPressMask bitor >>mask
- <- init-widget
-]
-
-"item-labels" !( keymenu -- labels ) [ $items [ first ] map ]
-
-"item-actions" !( keymenu -- actions ) [ $items [ second ] map ]
-
-"keymenu-labels" !( keymenu -- seq )
-[ numbers-and-letters swap <- item-labels [ " - " swap 3append ] 2map ]
-
-"reset-pen" !( keymenu -- keymenu ) [
- dup $pen
- 1 <-- set-x
- dup $gc $font <- ascent 1+ <-- set-y
- drop ]
-
-"handle-expose" !( event keymenu -- ) [
- nip
- <- reset-pen
- dup $pen swap <- keymenu-labels
- [ <-- draw-string dup $gc $font <- height <-- move-by-y ] each drop ]
-
-"keymenu-handle-key-press" !( event keymenu -- ) [
- swap 0 key-event-to-string numbers-and-letters index
- [ swap <- item-actions ?nth [ call ] when* ]
- [ drop ]
- if* ]
-
-"handle-key-press" !( event keymenu -- ) [ <- keymenu-handle-key-press ]
-
-"calc-height" !( keymenu -- height )
- [ dup $items length swap $pen $gc $font <- height * ]
-
-"calc-width" !( keymenu -- width )
- [ dup $pen $gc $font
- swap $items [ first " " append ] map
- dup empty? [ drop "" ] [ longest ] if
- <-- text-width ]
-
-"calc-size" !( keymenu -- size )
- [ dup <- calc-width swap <- calc-height 2array ]
-
-} add-methods
\ No newline at end of file
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-
-USING: kernel x11.xlib mortar mortar.sugar slot-accessors x.gc x.widgets ;
-
-IN: x.widgets.label
-
-SYMBOL: <label>
-
-<label> <widget> { "gc" "text" } accessors define-simple-class
-
-<label> "create" !( text <label> -- label ) [
-new-empty swap >>text <gc> new* >>gc ExposureMask >>mask <- init-widget
-] add-class-method
-
-<label> "handle-expose" !( event label -- ) [
- nip <- clear dup $gc { 20 20 } pick $text <---- draw-string
-] add-method
+++ /dev/null
-
-USING: kernel io namespaces arrays sequences combinators math x11.xlib
- mortar slot-accessors x ;
-
-IN: x.widgets
-
-SYMBOL: <widget>
-
-<widget> <window> { "mask" } accessors define-simple-class
-
-<widget> {
-
-"init-widget" !( widget -- widget )
- [ <- init-window <- add-to-window-table dup $mask <-- select-input ]
-
-"add-to-window-table" !( window -- window )
- [ dup $dpy over <-- add-to-window-table ]
-
-"remove-from-window-table" !( window -- window )
- [ dup $dpy over <-- remove-from-window-table ]
-
-"handle-event" !( event widget -- ) [
- over XAnyEvent-type
- { { [ dup Expose = ] [ drop <- handle-expose ] }
- { [ dup KeyPress = ] [ drop <- handle-key-press ] }
- { [ dup ButtonPress = ] [ drop <- handle-button-press ] }
- { [ dup EnterNotify = ] [ drop <- handle-enter-window ] }
- { [ dup DestroyNotify = ] [ drop <- handle-destroy-window ] }
- { [ dup MapRequest = ] [ drop <- handle-map-request ] }
- { [ dup MapNotify = ] [ drop <- handle-map ] }
- { [ dup ConfigureRequest = ] [ drop <- handle-configure-request ] }
- { [ dup UnmapNotify = ] [ drop <- handle-unmap ] }
- { [ dup PropertyNotify = ] [ drop <- handle-property ] }
- { [ t ] [ "handle-event :: ignoring event"
- print flush 3drop ] }
- } cond ]
-
-} add-methods
\ No newline at end of file
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-
-USING: kernel io namespaces arrays sequences
- x11.xlib mortar slot-accessors x x.widgets ;
-
-IN: x.widgets.wm.child
-
-SYMBOL: <wm-child>
-
-<wm-child> <widget> { } define-simple-class
-
-<wm-child> "create" !( id <wm-child> -- wm-child ) [
- new-empty swap >>id dpy get >>dpy PropertyChangeMask >>mask
- <- add-to-save-set
- 0 <-- set-border-width
- <- add-to-window-table
- dup $mask <-- select-input
-] add-class-method
-
-<wm-child> "handle-property" !( event wm-child -- ) [
- drop
- "child handle-property :: atom name = " write
- XPropertyEvent-atom get-atom-name print flush
-] add-method
\ No newline at end of file
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-
-USING: kernel namespaces arrays sequences combinators math.vectors
- x11.xlib x11.constants
- mortar slot-accessors x x.gc geom.rect ;
-
-IN: x.widgets.wm.frame.drag
-
-SYMBOL: <wm-frame-drag>
-
-<wm-frame-drag>
- { "dpy" "gc" "frame" "event" "push" "posn" } accessors
-define-independent-class
-
-<wm-frame-drag> {
-
-"next-event" !( wfdm -- wfdm ) [ dup $dpy over $event <-- next-event 2drop ]
-
-"event-type" !( wfdm -- wfdm event-type ) [ dup $event XAnyEvent-type ]
-
-"drag-offset" !( wfdm -- offset ) [ dup $posn swap $push v- ]
-
-"update-posn" !( wfd -- wfd ) [ dup $event XMotionEvent-root-position >>posn ]
-
-} add-methods
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-
-USING: kernel combinators namespaces math.vectors x11.xlib x11.constants
- mortar mortar.sugar slot-accessors x x.gc x.widgets.wm.frame.drag ;
-
-IN: x.widgets.wm.frame.drag.move
-
-SYMBOL: <wm-frame-drag-move>
-
-<wm-frame-drag-move> <wm-frame-drag> { } define-simple-class
-
-<wm-frame-drag-move> "create" !( event frame <wm-frame-drag-move> -- ) [
- new-empty swap >>frame swap >>event dup $frame $dpy >>dpy
-
- <gc> new*
- IncludeInferiors <-- set-subwindow-mode
- GXxor <-- set-function
- "white" <-- set-foreground
- >>gc
-
- dup $event XButtonEvent-root-position >>push
- dup $event XButtonEvent-root-position >>posn
- <- draw-move-outline
- <- loop
-] add-class-method
-
-<wm-frame-drag-move> {
-
-"move-outline" !( wfdm -- rect )
- [ dup $frame <- as-rect swap <- drag-offset <-- move-by ]
-
-"draw-move-outline" !( wfdm -- wfdm )
- [ dpy get $default-root over $gc pick <- move-outline <--- draw-rect ]
-
-"loop" !( wfdm -- wfdm ) [
- <- next-event
- { { [ <- event-type MotionNotify = ]
- [ <- draw-move-outline <- update-posn <- draw-move-outline <- loop ] }
- { [ <- event-type ButtonRelease = ]
- [ <- draw-move-outline
- dup $frame <- position over <- drag-offset v+ >r
- dup $frame r> <-- move drop
- dup $frame <- raise drop drop ] }
- { [ t ] [ <- loop ] } }
- cond ]
-
-} add-methods
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-
-USING: kernel combinators namespaces math.vectors x11.xlib x11.constants
- mortar mortar.sugar slot-accessors geom.rect x x.gc x.widgets.wm.frame.drag ;
-
-IN: x.widgets.wm.frame.drag.size
-
-SYMBOL: <wm-frame-drag-size>
-
-<wm-frame-drag-size> <wm-frame-drag> { } define-simple-class
-
-<wm-frame-drag-size> "create" !( event frame <wfds> -- ) [
- new-empty swap >>frame swap >>event
- dup $frame $dpy >>dpy
-
- <gc> new*
- IncludeInferiors <-- set-subwindow-mode
- GXxor <-- set-function
- "white" <-- set-foreground
- >>gc
-
- dup $event XButtonEvent-root-position >>push
- dup $event XButtonEvent-root-position >>posn
- <- draw-size-outline <- loop
-] add-class-method
-
-<wm-frame-drag-size> {
-
-"size-outline" !( wfds -- rect )
- [ dup $frame <- position swap $posn over v- <rect> new ]
-
-"draw-size-outline" !( wfdm -- wfdm )
- [ dup $dpy $default-root over $gc pick <- size-outline <--- draw-rect ]
-
-"loop" !( wfdm -- ) [
- <- next-event
- { { [ <- event-type MotionNotify = ]
- [ <- draw-size-outline <- update-posn <- draw-size-outline <- loop ] }
- { [ <- event-type ButtonRelease = ]
- [ <- draw-size-outline
- dup $frame over $posn pick $frame <- position v- <-- resize
- <- adjust-child drop ] }
- { [ t ] [ <- loop ] } }
- cond ]
-
-} add-methods
\ No newline at end of file
+++ /dev/null
-
-USING: kernel io combinators namespaces quotations arrays sequences
- math math.vectors
- x11.xlib x11.constants
- mortar mortar.sugar slot-accessors
- geom.rect
- math.bitwise
- x x.gc x.widgets
- x.widgets.button
- x.widgets.wm.child
- x.widgets.wm.frame.drag.move
- x.widgets.wm.frame.drag.size ;
-
-IN: x.widgets.wm.frame
-
-SYMBOL: <wm-frame>
-
-<wm-frame> <widget> { "child" "gc" "last-state" } accessors define-simple-class
-
-<wm-frame> "create" !( id <wm-frame> -- wm-frame ) [
- new-empty
- swap <wm-child> new* >>child
- <gc> new* "white" <-- set-foreground >>gc
-
- {
- SubstructureRedirectMask
- ExposureMask
- ButtonPressMask
- ButtonReleaseMask
- ButtonMotionMask
- EnterWindowMask
- ! experimental masks
- SubstructureNotifyMask
- } flags
- >>mask
-
- <- init-widget
- "cornflowerblue" <-- set-background
- dup $child <- position <-- move
- dup $child over <-- reparent drop
- <- position-child
- <- fit-to-child
- <- make-frame-button
-
- <- map-subwindows
- <- map
-] add-class-method
-
-SYMBOL: WM_PROTOCOLS
-SYMBOL: WM_DELETE_WINDOW
-
-: init-atoms ( -- )
-"WM_PROTOCOLS" 0 intern-atom WM_PROTOCOLS set
-"WM_DELETE_WINDOW" 0 intern-atom WM_DELETE_WINDOW set ;
-
-<wm-frame> {
-
-"fit-to-child" !( wm-frame -- wm-frame )
- [ dup $child <- size { 10 20 } v+ <-- resize ]
-
-"position-child" !( wm-frame -- wm-frame )
- [ dup $child { 5 15 } <-- move drop ]
-
-"set-child-size" !( wm-frame size -- frame )
- [ >r dup $child r> <-- resize drop <- fit-to-child ]
-
-"set-child-width" !( wm-frame width -- frame )
- [ >r dup $child r> <- set-width drop <- fit-to-child ]
-
-"set-child-height" !( wm-frame height -- frame )
- [ >r dup $child r> <- set-height drop <- fit-to-child ]
-
-"adjust-child" !( wm-frame -- wm-frame )
- [ dup $child over <- size { 10 20 } v- <-- resize drop ]
-
-"update-title" !( wm-frame -- wm-frame )
- [ <- clear
- dup >r
- ! dup $gc { 5 1 } pick $child <- fetch-name <--- draw-string/top-left
- dup $gc { 5 11 } pick $child <- fetch-name <---- draw-string
- r> ]
-
-"delete-child" !( wm-frame -- wm-frame ) [
- dup $child WM_PROTOCOLS get WM_DELETE_WINDOW get <--- send-client-message
- drop ]
-
-"drag-move" !( event wm-frame -- ) [ <wm-frame-drag-move> new* ]
-
-"drag-size" !( event wm-frame -- ) [ <wm-frame-drag-size> new* ]
-
-"make-frame-button" !( frame -- frame ) [
-<button> new*
- over <-- reparent
- "" >>text
- over [ <- unmap drop ] curry >>action-1
- over [ <- delete-child drop ] curry >>action-3
- { 9 9 } <-- resize
- NorthEastGravity <-- set-gravity
- "white" <-- set-background
- over <- width 9 - 5 - 3 2array <-- move
- drop ]
-
-! !!!!!!!!!! Event handlers !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-"handle-enter-window" !( event wm-frame -- )
- [ nip $child RevertToPointerRoot CurrentTime <--- set-input-focus drop ]
-
-"handle-expose" !( event wm-frame -- ) [ nip <- clear <- update-title drop ]
-
-"handle-button-press" !( event wm-frame -- ) [
- over XButtonEvent-button
- { { [ dup Button1 = ] [ drop <- drag-move ] }
- { [ dup Button2 = ] [ drop <- drag-size ] }
- { [ t ] [ 3drop ] } }
- cond ]
-
-"handle-map" !( event wm-frame -- )
- [ "<wm-frame> handle-map :: ignoring values" print flush 2drop ]
-
-"handle-unmap" !( event wm-frame -- ) [ nip <- unmap drop ]
-
-"handle-destroy-window" !( event wm-frame -- ) [
- nip dup $child <- remove-from-window-table drop
- <- remove-from-window-table <- destroy ]
-
-"handle-configure-request" !( event frame -- ) [
- { { [ over dup CWX? swap CWY? and ]
- [ over XConfigureRequestEvent-position <-- move ] }
- { [ over CWX? ] [ over XConfigureRequestEvent-x <-- set-x ] }
- { [ over CWY? ] [ over XConfigureRequestEvent-y <-- set-y ] }
- { [ t ] [ "<wm-frame> handle-configure-request :: move not requested"
- print flush ] } }
- cond
-
- { { [ over dup CWWidth? swap CWHeight? and ]
- [ over XConfigureRequestEvent-size <-- set-child-size ] }
- { [ over CWWidth? ]
- [ over XConfigureRequestEvent-width <-- set-child-width ] }
- { [ over CWHeight? ]
- [ over XConfigureRequestEvent-height <-- set-child-height ] }
- { [ t ]
- [ "<wm-frame> handle-configure-request :: resize not requested"
- print flush ] } }
- cond
- 2drop ]
-
-} add-methods
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: wm-frame-maximize ( wm-frame -- wm-frame )
-<- save-state
-{ 0 0 } <-- move
-dup $dpy $default-root <- size
- <-- resize
-<- adjust-child
-<- raise ;
-
-: wm-frame-maximize-vertical ( wm-frame -- wm-frame )
-0 <-- set-y
-dup $dpy $default-root <- height
- <-- set-height
-<- adjust-child ;
-
-<wm-frame> "save-state" !( wm-frame -- wm-frame ) [
- dup <- position
- over <- size
- <rect> new
- >>last-state
-] add-method
-
-<wm-frame> "restore-state" !( wm-frame -- wm-frame ) [
- dup $last-state $pos <-- move
- dup $last-state $dim <-- resize
- <- adjust-child
-] add-method
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-
-USING: kernel x11.constants mortar mortar.sugar slot-accessors x.widgets.keymenu ;
-
-IN: x.widgets.wm.menu
-
-SYMBOL: <wm-menu>
-
-<wm-menu> <keymenu> { } define-simple-class
-
-<wm-menu> "create" !( <wm-menu> -- wm-menu )
- [ new-empty <- keymenu-init ]
-add-class-method
-
-<wm-menu> {
-
-"wm-menu-handle-key-press" !( event wm-menu -- )
- [ <- unmap <- keymenu-handle-key-press ]
-
-"handle-key-press" !( event wm-menu -- ) [ <- wm-menu-handle-key-press ]
-
-"wm-menu-popup" !( wm-menu -- wm-menu )
- [ <- map <- raise RevertToPointerRoot CurrentTime <--- set-input-focus ]
-
-"popup" !( wm-menu -- wm-menu ) [ <- wm-menu-popup ]
-
-} add-methods
\ No newline at end of file
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-
-USING: kernel io combinators namespaces arrays assocs sequences math
- x11.xlib
- x11.constants
- vars mortar slot-accessors
- x x.keysym-table x.widgets x.widgets.wm.child x.widgets.wm.frame ;
-
-IN: x.widgets.wm.root
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-SYMBOL: <wm-root>
-
-<wm-root>
- <widget>
- { "keymap" } accessors
-define-simple-class
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-VAR: wm-root
-
-: create-wm-root ( -- )
- <wm-root> new-empty
- dpy> >>dpy
- dpy> $default-root $id >>id
- SubstructureRedirectMask >>mask
- <- add-to-window-table
- SubstructureRedirectMask <-- select-input
- H{ } clone >>keymap
- >wm-root ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: find-in-table ( window -- object )
-dup >r $id dpy get $window-table at r> or ;
-
-: circulate-focus ( -- )
-dpy get $default-root <- children
-[ find-in-table ] map [ <- mapped? ] filter dup length 1 >
-[ reverse dup first <- lower drop
- second <- raise
- dup <wm-frame> is? [ $child ] [ ] if
- RevertToPointerRoot CurrentTime <--- set-input-focus drop ]
-[ drop ]
-if ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: managed? ( id -- ? )
-dpy get $window-table values [ <wm-child> is? ] filter [ $id ] map member? ;
-
-: event>keyname ( event -- keyname ) lookup-keysym keysym>name ;
-
-: event>state-and-name ( event -- array )
-dup XKeyEvent-state swap event>keyname 2array ;
-
-: resolve-key-event ( keymap event -- item ) event>state-and-name swap at ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-<wm-root> {
-
-"handle-map-request" !( event wm-root -- ) [
- { { [ over XMapRequestEvent-window managed? ]
- [ "<wm-root> handle-map-request :: window already managed" print flush
- 2drop ] }
- { [ t ] [ drop XMapRequestEvent-window <wm-frame> <<- create drop ] } }
- cond ]
-
-"handle-unmap" !( event wm-root -- ) [ 2drop ]
-
-"handle-key-press" !( event wm-root -- )
- [ $keymap swap resolve-key-event call ]
-
-"grab-key" !( wm-root modifiers keyname -- wm-root modifiers keyname ) [
- 3dup name>keysym keysym-to-keycode spin
- False GrabModeAsync GrabModeAsync grab-key ]
-
-"set-key-action" !( wm-root modifiers keyname action -- wm-root ) [
- >r <--- grab-key r>
- -rot 2array pick $keymap set-at ]
-
-"handle-configure-request" !( event wm-root -- ) [
- $dpy over XConfigureRequestEvent-window <window> new ! event window
- { { [ over dup CWX? swap CWY? and ]
- [ over XConfigureRequestEvent-position <-- move ] }
- { [ over CWX? ] [ over XConfigureRequestEvent-x <-- set-x ] }
- { [ over CWY? ] [ over XConfigureRequestEvent-y <-- set-y ] }
- { [ t ] [ "<wm-root> handle-configure-request :: move not requested"
- print flush ] } }
- cond
-
- { { [ over dup CWWidth? swap CWHeight? and ]
- [ over XConfigureRequestEvent-size <-- resize ] }
- { [ over CWWidth? ] [ over XConfigureRequestEvent-width <-- set-width ] }
- { [ over CWHeight? ] [ over XConfigureRequestEvent-height <-- set-height ] }
- { [ t ] [ "<wm-root> handle-configure-request :: resize not requested"
- print flush ] } }
- cond
- 2drop ]
-
-} add-methods
\ No newline at end of file
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-
-USING: kernel namespaces quotations arrays assocs sequences
- mortar slot-accessors x x.widgets.wm.menu x.widgets.wm.frame
- vars ;
-
-IN: x.widgets.wm.unmapped-frames-menu
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-SYMBOL: <unmapped-frames-menu>
-
-<unmapped-frames-menu> <wm-menu> { } define-simple-class
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-VAR: unmapped-frames-menu
-
-: create-unmapped-frames-menu ( -- )
-<unmapped-frames-menu>
- new-empty
- <- keymenu-init
- 1 <-- set-border-width
->unmapped-frames-menu ;
-
-: unmapped-frames ( -- seq )
-dpy get $window-table values
-[ <wm-frame> is? ] filter [ <- mapped? not ] filter ;
-
-<unmapped-frames-menu> {
-
-"refresh" !( menu -- menu ) [
- unmapped-frames dup
- [ $child <- fetch-name ] map swap
- [ [ <- map ] curry ] map
- [ 2array ] 2map
- >>items
- dup <- calc-size <-- resize ]
-
-"popup" !( menu -- menu ) [ <- refresh <- wm-menu-popup ]
-
-} add-methods
\ No newline at end of file
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-
-USING: kernel namespaces namespaces.lib math sequences vars mortar
-accessors slot-accessors x ;
-
-IN: x.widgets.wm.workspace
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-TUPLE: workspace windows ;
-
-C: <workspace> workspace
-
-VAR: workspaces
-
-VAR: current-workspace
-
-: init-workspaces ( -- ) V{ } clone >workspaces ;
-
-: add-workspace ( -- ) { } clone <workspace> workspaces> push ;
-
-: mapped-windows ( -- seq )
-dpy get $default-root <- children [ <- mapped? ] filter ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: switch-to-workspace ( n -- )
-mapped-windows current-workspace> workspaces> nth (>>windows)
-mapped-windows [ <- unmap drop ] each
-dup workspaces> nth windows>> [ <- map drop ] each
-current-workspace set* ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: next-workspace ( -- )
-current-workspace> 1+ dup workspaces> length <
-[ switch-to-workspace ] [ drop ] if ;
-
-: prev-workspace ( -- )
-current-workspace> 1- dup 0 >=
-[ switch-to-workspace ] [ drop ] if ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: setup-workspaces ( n -- )
-workspaces>
- [ drop ]
- [ init-workspaces [ add-workspace ] times 0 >current-workspace ]
-if ;
\ No newline at end of file
+++ /dev/null
-
-USING: kernel io alien alien.c-types alien.strings namespaces threads
- arrays sequences assocs math vars combinators.lib
- x11.constants x11.events x11.xlib mortar slot-accessors geom.rect
- io.encodings.ascii ;
-
-IN: x
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-SYMBOL: <display>
-
-SYMBOL: <window>
-
-! SYMBOL: dpy
-
-VAR: dpy
-
-<display>
- { "ptr"
- "name"
- "default-screen"
- "default-root"
- "default-gc"
- "black-pixel"
- "white-pixel"
- "colormap"
- "window-table" } accessors
-define-independent-class
-
-<display> "create" !( name <display> -- display ) [
- new-empty swap >>name
- dup $name dup [ ascii string>alien ] [ ] if XOpenDisplay
- dup [ >>ptr ] [ "XOpenDisplay error" throw ] if
- dup $ptr XDefaultScreen >>default-screen
- dup $ptr XDefaultRootWindow dupd <window> new >>default-root
- dup $ptr over $default-screen XDefaultGC >>default-gc
- dup $ptr over $default-screen XBlackPixel >>black-pixel
- dup $ptr over $default-screen XWhitePixel >>white-pixel
- dup $ptr over $default-screen XDefaultColormap >>colormap
- H{ } clone >>window-table
- [ <- start-event-loop ] in-thread
-] add-class-method
-
-{ "id" } accessors drop
-
-DEFER: check-window-table
-
-<display> {
-
-"add-to-window-table" !( display window -- )
- [ dup $id rot $window-table set-at ]
-
-"remove-from-window-table" !( display window -- )
- [ $id swap $window-table delete-at ]
-
-"next-event" !( display event -- display event )
- [ over $ptr over XNextEvent drop ]
-
-"events-queued" !( display mode -- n ) [ >r $ptr r> XEventsQueued ]
-
-"concurrent-next-event" !( display event -- display event )
- [ over QueuedAfterFlush <-- events-queued 0 >
- [ <-- next-event ] [ 100 sleep <-- concurrent-next-event ] if ]
-
-"event-loop" !( display event -- )
-[ <-- concurrent-next-event
- 2dup >r >r
- dup XAnyEvent-window rot $window-table at dup
- [ <- handle-event ] [ 2drop ] if
- r> r>
- <-- event-loop ]
-
-"start-event-loop" !( display -- ) [ "XEvent" <c-object> <-- event-loop ]
-
-"flush" !( display -- display ) [ dup $ptr XFlush drop ]
-
-"pointer-window" !( display -- window ) [
- dup $ptr
- over $default-root $id
- 0 <Window>
- 0 <Window> dup >r
- 0 <int>
- 0 <int>
- 0 <int>
- 0 <int>
- 0 <uint>
- XQueryPointer drop
- r> *Window <window> new
- check-window-table ]
-
-} add-methods
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-<window> { "dpy" "id" } accessors define-independent-class
-
-: create-window ( -- window ) <window> new-empty <- init-window ;
-
-: create-window-from-id ( dpy id -- window ) <window> new ;
-
-: check-window-table ( window -- window )
- dup $id
- over $dpy $window-table
- at
- swap or ;
-
-<window> "init-window"
- !( window -- window )
- [ dpy get
- >>dpy
- dpy get $ptr
- dpy get $default-root $id
- 0 0 100 100 0
- dpy get $black-pixel
- dpy get $white-pixel
- XCreateSimpleWindow
- >>id ]
-add-method
-
-! <window> new-empty <- init
-
-<window> "raw"
- !( window -- dpy-ptr id )
- [ dup $dpy $ptr swap $id ]
-add-method
-
-<window> "move"
- !( window point -- window )
- [ >r dup <- raw r> first2 XMoveWindow drop ]
-add-method
-
-<window> "set-x" !( window x -- window ) [
- over <- y 2array <-- move
-] add-method
-
-<window> "set-y" !( window y -- window ) [
- over <- x swap 2array <-- move
-] add-method
-
-<window> "flush"
- !( window -- window )
- [ dup $dpy <- flush drop ]
-add-method
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! 3 - Window Functions
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! 3.3 - Creating Windows
-
-<window> "destroy" !( window -- window )
- [ dup <- raw XDestroyWindow drop ]
-add-method
-
-<window> "map"
- !( window -- window )
- [ dup <- raw XMapWindow drop ]
-add-method
-
-<window> "map-subwindows"
- !( window -- window )
- [ dup <- raw XMapSubwindows drop ]
-add-method
-
-<window> "unmap"
- !( window -- window )
- [ dup <- raw XUnmapWindow drop ]
-add-method
-
-<window> "unmap-subwindows"
- !( window -- window )
- [ dup <- raw XUnmapSubwindows drop ]
-add-method
-
-! 3.7 - Configuring Windows
-
-<window> "resize"
- !( window size -- window )
- [ >r dup <- raw r> first2 XResizeWindow drop ]
-add-method
-
-<window> "set-width"
- !( window width -- window )
- [ over <- height 2array <-- resize ]
-add-method
-
-<window> "set-height"
- !( window height -- window )
- [ over <- width swap 2array <-- resize ]
-add-method
-
-<window> "set-border-width"
- !( window n -- window )
- [ >r dup <- raw r> XSetWindowBorderWidth drop ]
-add-method
-
-! 3.8 Changing Window Stacking Order
-
-<window> "raise"
- !( window -- window )
- [ dup <- raw XRaiseWindow drop ]
-add-method
-
-<window> "lower"
- !( window -- window )
- [ dup <- raw XLowerWindow drop ]
-add-method
-
-! 3.9 - Changing Window Attributes
-
-! : change-window-attributes ( valuemask attr window -- )
-! -rot >r >r <- raw r> r> XChangeWindowAttributes drop ;
-
-<window> "change-attributes" !( window valuemask attr -- window ) [
->r >r dup <- raw r> r> XChangeWindowAttributes drop
-] add-method
-
-DEFER: lookup-color
-
-<window> "set-background"
- !( window color -- window )
- [ >r dup <- raw r> lookup-color XSetWindowBackground drop ]
-add-method
-
-<window> "set-gravity" !( window gravity -- window ) [
-CWWinGravity swap
-"XSetWindowAttributes" <c-object> tuck set-XSetWindowAttributes-win_gravity
-<--- change-attributes
-] add-method
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! 4 - Window Information Functions
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! 4.1 - Obtaining Window Information
-
-<window> {
-
-"children" !( window -- seq )
- [ <- raw 0 <uint> 0 <uint> f <void*> 0 <uint> 2dup >r >r XQueryTree drop
- r> r> swap *void* swap *uint c-uint-array>
- [ dpy get swap <window> new ] map ]
-
-"parent" !( window -- parent ) [
- dup $dpy >r
-
- dup $dpy $ptr
- swap $id
- 0 <Window>
- 0 <Window> dup >r
- f <void*>
- 0 <uint>
- XQueryTree drop
- r> *Window
- r> swap
- <window> new
- check-window-table ]
-
-"size" !( window -- size )
- [ <- raw 0 <Window> 0 <int> 0 <int>
- 0 <uint> 0 <uint> 2dup 2array >r
- 0 <uint> 0 <uint>
- XGetGeometry drop r> [ *uint ] map ]
-
-"width" !( window -- width ) [ <- size first ]
-
-"height" !( window -- height ) [ <- size second ]
-
-"position" !( window -- position )
- [ <- raw 0 <Window>
- 0 <uint> 0 <uint> 2dup 2array >r
- 0 <uint> 0 <uint> 0 <uint> 0 <uint>
- XGetGeometry drop r> [ *int ] map ]
-
-"x" !( window -- x ) [ <- position first ]
-
-"y" !( window -- y ) [ <- position second ]
-
-"as-rect" !( window -- rect ) [ dup <- position swap <- size <rect> new ]
-
-"attributes" !( window -- XWindowAttributes )
- [ <- raw "XWindowAttributes" <c-object> dup >r XGetWindowAttributes drop r> ]
-
-"map-state" !( window -- state ) [ <- attributes XWindowAttributes-map_state ]
-
-"mapped?" !( window -- ? ) [ <- map-state IsUnmapped = not ]
-
-} add-methods
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: get-atom-name ( atom -- name ) dpy get $ptr swap XGetAtomName ;
-
-: intern-atom ( atom-name only-if-exists? -- atom )
-dpy get $ptr -rot XInternAtom ;
-
-: lookup-color ( name -- pixel )
-dpy get $ptr dpy get $colormap rot
-"XColor" <c-object> dup >r "XColor" <c-object> XLookupColor drop
-dpy get $ptr dpy get $colormap r> dup >r XAllocColor drop r> XColor-pixel ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! 8 - Graphics Functions
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-<window> "clear"
- !( window -- window )
- [ dup <- raw XClearWindow drop ]
-add-method
-
-<window> "draw-string"
- !( window gc pos string -- )
- [ >r >r >r <- raw r> $ptr r> [ >fixnum ] map first2 r> dup length
- XDrawString drop ]
-add-method
-
-! <window> "draw-string"
-! !( window gc pos string -- )
-! [ >r >r >r <- raw r> $ptr r> [ >fixnum ] map first2 r> dup length
-! XDrawString drop ]
-! add-method
-
-<window> "draw-line"
- !( window gc a b -- )
- [ >r >r >r <- raw r> $ptr r> first2 r> first2 XDrawLine drop ]
-add-method
-
-<window> "draw-rect"
- !( window gc rect -- )
- [ 3dup dup <- top-left swap <- top-right <---- draw-line
- 3dup dup <- top-right swap <- bottom-right <---- draw-line
- 3dup dup <- bottom-left swap <- bottom-right <---- draw-line
- dup <- top-left swap <- bottom-left <---- draw-line ]
-add-method
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! 9 - Window and Session Manager Functions
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-<window> "reparent"
- !( window parent -- window )
- [ >r dup <- raw r> $id 0 0 XReparentWindow drop ]
-add-method
-
-<window> "add-to-save-set" !( window -- window ) [
- dup <- raw XAddToSaveSet drop
-] add-method
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! 10 - Events
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: XButtonEvent-root-position ( event -- position )
-dup XButtonEvent-x_root swap XButtonEvent-y_root 2array ;
-
-: XMotionEvent-root-position ( event -- position )
-dup XMotionEvent-x_root swap XMotionEvent-y_root 2array ;
-
-! Utility words for XConfigureRequestEvent
-
-: XConfigureRequestEvent-position ( XConfigureRequestEvent -- position )
-dup XConfigureRequestEvent-x swap XConfigureRequestEvent-y 2array ;
-
-: XConfigureRequestEvent-size ( XConfigureRequestEvent -- size )
-dup XConfigureRequestEvent-width swap XConfigureRequestEvent-height 2array ;
-
-: bit-test ( a b -- t-or-f ) bitand 0 = not ;
-
-: CWX? ( XConfigureRequestEvent -- bool )
-XConfigureRequestEvent-value_mask CWX bit-test ;
-
-: CWY? ( XConfigureRequestEvent -- bool )
-XConfigureRequestEvent-value_mask CWY bit-test ;
-
-: CWWidth? ( XConfigureRequestEvent -- bool )
-XConfigureRequestEvent-value_mask CWWidth bit-test ;
-
-: CWHeight? ( XConfigureRequestEvent -- bool )
-XConfigureRequestEvent-value_mask CWHeight bit-test ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! 11 - Event Handling Functions
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-<window> "select-input"
- !( window mask -- window )
- [ >r dup <- raw r> XSelectInput drop ]
-add-method
-
-! 11.8 - Handling Protocol Errors
-
-SYMBOL: error-handler-quot
-
-: error-handler-callback ( -- xt )
-"void" { "Display*" "XErrorEvent*" } "cdecl"
-[ error-handler-quot get call ] alien-callback ;
-
-: set-error-handler ( quot -- )
-error-handler-quot set error-handler-callback XSetErrorHandler drop ;
-
-: install-default-error-handler ( -- )
-[ "X11 : error-handler called" print flush ] set-error-handler ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! 12 - Input Device Functions
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! 12.2 - Keyboard Grabbing
-
-: grab-key
-( keycode modifiers grab-window owner-events pointer-mode keyboard-mode -- )
->r >r >r <- raw >r -rot r> r> r> r> XGrabKey drop ;
-
-! 12.5 - Controlling Input Focus
-
-<window> "set-input-focus" !( window revert-to time -- window )
- [ >r >r dup <- raw r> r> XSetInputFocus drop ]
-add-method
-
-: get-input-focus ( -- window )
- dpy> $ptr
- 0 <Window> dup >r
- 0 <int>
- XGetInputFocus drop
- r> *Window
- dpy> swap
- create-window-from-id
- check-window-table ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! 14 - Inter-Client Communication Functions
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-<window> "fetch-name" !( window -- name-or-f )
- [ <- raw f <void*> dup >r XFetchName drop r>
- dup *void* [ drop f ] [ *void* ascii alien>string ] if ]
-add-method
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! 16 - Application Utility Functions
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! 16.1 - Using Keyboard Utility Functions
-
-! this should go in xlib.factor
-
-USING: alien.syntax ;
-
-FUNCTION: KeyCode XKeysymToKeycode ( Display* display, KeySym keysym ) ;
-
-FUNCTION: KeySym XKeycodeToKeysym ( Display* display,
- KeyCode keycode,
- int index ) ;
-
-FUNCTION: char* XKeysymToString ( KeySym keysym ) ;
-
-: keysym-to-keycode ( keysym -- keycode ) dpy get $ptr swap XKeysymToKeycode ;
-
-USE: strings
-
-: lookup-string* ( event -- keysym string )
-10 "char" <c-array> dup >r 10 0 <KeySym> dup >r f XLookupString
-r> *KeySym swap r> swap c-char-array> >string ;
-
-: lookup-string ( event -- string ) lookup-string* nip ;
-
-: lookup-keysym ( event -- keysym ) lookup-string* drop ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!7
-
-: event-to-keysym ( event index -- keysym )
->r dup XKeyEvent-display swap XKeyEvent-keycode r> XKeycodeToKeysym ;
-
-: keysym-to-string ( keysym -- string ) XKeysymToString ;
-
-: key-event-to-string ( event index -- str ) event-to-keysym keysym-to-string ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! Misc
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: no-modifiers ( -- mask ) 0 ;
-
-: control-alt ( -- mask ) ControlMask Mod1Mask bitor ;
-
-: alt ( -- mask ) Mod1Mask ;
-
-: True 1 ;
-: False 0 ;
-
-<window> "send-client-message" !( window message-type data -- window ) [
-
-"XClientMessageEvent" <c-object>
-
-tuck set-XClientMessageEvent-data0
-tuck set-XClientMessageEvent-message_type
-over $id over set-XClientMessageEvent-window
-ClientMessage over set-XClientMessageEvent-type
-32 over set-XClientMessageEvent-format
-CurrentTime over set-XClientMessageEvent-data1
-
->r dup <- raw False NoEventMask r> XSendEvent drop
-
-] add-method
\ No newline at end of file
-;; Eduardo Cavazos - wayo.cavazos@gmail.com
+;;; factor.el --- Interacting with Factor within emacs
+;;
+;; Authors: Eduardo Cavazos <wayo.cavazos@gmail.com>
+;; Jose A Ortega Ruiz <jao@gnu.org>
+;; Keywords: languages
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Add these lines to your .emacs file:
+;;; Commentary:
-;; (load-file "/scratch/repos/Factor/misc/factor.el")
-;; (setq factor-binary "/scratch/repos/Factor/factor")
-;; (setq factor-image "/scratch/repos/Factor/factor.image")
+;;; Quick setup:
+;; Add these lines to your .emacs file:
+;;
+;; (load-file "/scratch/repos/Factor/misc/factor.el")
+;; (setq factor-binary "/scratch/repos/Factor/factor")
+;; (setq factor-image "/scratch/repos/Factor/factor.image")
+;;
;; Of course, you'll have to edit the directory paths for your system
-;; accordingly.
-
+;; accordingly. Alternatively, put this file in your load-path and use
+;;
+;; (require 'factor)
+;;
+;; instead of load-file.
+;;
;; That's all you have to do to "install" factor.el on your
;; system. Whenever you edit a factor file, Emacs will know to switch
;; to Factor mode.
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; For further customization options,
+;; M-x customize-group RET factor
+;;
+;; To start a Factor listener inside Emacs,
+;; M-x run-factor
-;; M-x run-factor === Start a Factor listener inside Emacs
+;;; Requirements:
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Customization
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(require 'font-lock)
+(require 'comint)
+
+;;; Customization:
(defgroup factor nil
"Factor mode"
:type 'integer
:group 'factor)
+(defcustom factor-binary "~/factor/factor"
+ "Full path to the factor executable to use when starting a listener."
+ :type '(file :must-match t)
+ :group 'factor)
+
+(defcustom factor-image "~/factor/factor.image"
+ "Full path to the factor image to use when starting a listener."
+ :type '(file :must-match t)
+ :group 'factor)
+
(defcustom factor-display-compilation-output t
"Display the REPL buffer before compiling files."
- :type '(choice (const :tag "Enable" t) (const :tag "Disable" nil))
+ :type 'boolean
:group 'factor)
(defcustom factor-mode-hook nil
:type 'hook
:group 'factor)
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; factor-mode syntax
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(defvar factor-mode-syntax-table nil
- "Syntax table used while in Factor mode.")
-
-(if factor-mode-syntax-table
- ()
- (let ((i 0))
- (setq factor-mode-syntax-table (make-syntax-table))
-
- ;; Default is atom-constituent
- (while (< i 256)
- (modify-syntax-entry i "_ " factor-mode-syntax-table)
- (setq i (1+ i)))
-
- ;; Word components.
- (setq i ?0)
- (while (<= i ?9)
- (modify-syntax-entry i "w " factor-mode-syntax-table)
- (setq i (1+ i)))
- (setq i ?A)
- (while (<= i ?Z)
- (modify-syntax-entry i "w " factor-mode-syntax-table)
- (setq i (1+ i)))
- (setq i ?a)
- (while (<= i ?z)
- (modify-syntax-entry i "w " factor-mode-syntax-table)
- (setq i (1+ i)))
-
- ;; Whitespace
- (modify-syntax-entry ?\t " " factor-mode-syntax-table)
- (modify-syntax-entry ?\n ">" factor-mode-syntax-table)
- (modify-syntax-entry ?\f " " factor-mode-syntax-table)
- (modify-syntax-entry ?\r " " factor-mode-syntax-table)
- (modify-syntax-entry ? " " factor-mode-syntax-table)
-
- (modify-syntax-entry ?\[ "(] " factor-mode-syntax-table)
- (modify-syntax-entry ?\] ")[ " factor-mode-syntax-table)
- (modify-syntax-entry ?{ "(} " factor-mode-syntax-table)
- (modify-syntax-entry ?} "){ " factor-mode-syntax-table)
-
- (modify-syntax-entry ?\( "()" factor-mode-syntax-table)
- (modify-syntax-entry ?\) ")(" factor-mode-syntax-table)
- (modify-syntax-entry ?\" "\" " factor-mode-syntax-table)))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; factor-mode font lock
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(require 'font-lock)
-
(defgroup factor-faces nil
"Faces used in Factor mode"
:group 'factor
"Face for parsing words."
:group 'factor-faces)
+\f
+;;; Factor mode font lock:
+
(defconst factor--parsing-words
'("{" "}" "^:" "^::" ";" "<<" "<PRIVATE" ">>"
"BIN:" "BV{" "B{" "C:" "C-STRUCT:" "C-UNION:" "CHAR:" "CS{" "C{"
(,factor--regex-type-definition 2 'factor-font-lock-type-definition)
(,factor--regex-symbol-definition 2 'factor-font-lock-symbol-definition)
(,factor--regex-using-line 1 'factor-font-lock-vocabulary-name)
- (,factor--regex-use-line 1 'factor-font-lock-vocabulary-name)))
+ (,factor--regex-use-line 1 'factor-font-lock-vocabulary-name))
+ "Font lock keywords definition for Factor mode.")
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; factor-mode commands
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+\f
+;;; Factor mode syntax:
-(require 'comint)
+(defvar factor-mode-syntax-table nil
+ "Syntax table used while in Factor mode.")
+
+(if factor-mode-syntax-table
+ ()
+ (let ((i 0))
+ (setq factor-mode-syntax-table (make-syntax-table))
+
+ ;; Default is atom-constituent
+ (while (< i 256)
+ (modify-syntax-entry i "_ " factor-mode-syntax-table)
+ (setq i (1+ i)))
+
+ ;; Word components.
+ (setq i ?0)
+ (while (<= i ?9)
+ (modify-syntax-entry i "w " factor-mode-syntax-table)
+ (setq i (1+ i)))
+ (setq i ?A)
+ (while (<= i ?Z)
+ (modify-syntax-entry i "w " factor-mode-syntax-table)
+ (setq i (1+ i)))
+ (setq i ?a)
+ (while (<= i ?z)
+ (modify-syntax-entry i "w " factor-mode-syntax-table)
+ (setq i (1+ i)))
-(defvar factor-binary "~/factor/factor")
-(defvar factor-image "~/factor/factor.image")
+ ;; Whitespace
+ (modify-syntax-entry ?\t " " factor-mode-syntax-table)
+ (modify-syntax-entry ?\n ">" factor-mode-syntax-table)
+ (modify-syntax-entry ?\f " " factor-mode-syntax-table)
+ (modify-syntax-entry ?\r " " factor-mode-syntax-table)
+ (modify-syntax-entry ? " " factor-mode-syntax-table)
+
+ (modify-syntax-entry ?\[ "(] " factor-mode-syntax-table)
+ (modify-syntax-entry ?\] ")[ " factor-mode-syntax-table)
+ (modify-syntax-entry ?{ "(} " factor-mode-syntax-table)
+ (modify-syntax-entry ?} "){ " factor-mode-syntax-table)
+
+ (modify-syntax-entry ?\( "()" factor-mode-syntax-table)
+ (modify-syntax-entry ?\) ")(" factor-mode-syntax-table)
+ (modify-syntax-entry ?\" "\" " factor-mode-syntax-table)))
+
+\f
+;;; Factor mode commands:
(defun factor-telnet-to-port (port)
(interactive "nPort: ")
(unless (get-buffer-window (current-buffer) t)
(display-buffer (current-buffer) t))))
-;; (defun factor-send-region (start end)
-;; (interactive "r")
-;; (comint-send-region "*factor*" start end)
-;; (comint-send-string "*factor*" "\n"))
-
(defun factor-send-string (str)
(let ((n (length (split-string str "\n"))))
(save-excursion
(beginning-of-line)
(insert "! "))
-(defvar factor-mode-map (make-sparse-keymap))
+(defvar factor-mode-map (make-sparse-keymap)
+ "Key map used by Factor mode.")
(define-key factor-mode-map "\C-c\C-f" 'factor-run-file)
(define-key factor-mode-map "\C-c\C-r" 'factor-send-region)
(define-key factor-mode-map [return] 'newline-and-indent)
(define-key factor-mode-map [tab] 'indent-for-tab-command)
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; factor-mode indentation
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+\f
+;;; Factor mode indentation:
-(defconst factor-word-starting-keywords
- '("" ":" "TUPLE" "MACRO" "MACRO:" "M"))
+(make-variable-buffer-local
+ (defvar factor-indent-width factor-default-indent-width
+ "Indentation width in factor buffers. A local variable."))
-(defmacro factor-word-start-re (keywords)
- `(format
- "^\\(%s\\): "
- (mapconcat 'identity ,keywords "\\|")))
-
-(defvar factor-indent-width factor-default-indent-width
- "Indentation width in factor buffers. A local variable.")
-
-(make-variable-buffer-local 'factor-indent-width)
+(defconst factor--regexp-word-start
+ (let ((sws '("" ":" "TUPLE" "MACRO" "MACRO:" "M")))
+ (format "^\\(%s\\): " (mapconcat 'identity sws "\\|"))))
(defun factor--guess-indent-width ()
"Chooses an indentation value from existing code."
- (let ((word-def (factor-word-start-re factor-word-starting-keywords))
- (word-cont "^ +[^ ]")
+ (let ((word-cont "^ +[^ ]")
(iw))
(save-excursion
(beginning-of-buffer)
(while (not iw)
- (if (not (re-search-forward word-def nil t))
+ (if (not (re-search-forward factor--regexp-word-start nil t))
(setq iw factor-default-indent-width)
(forward-line)
(when (looking-at word-cont)
(setq iw (current-indentation))))))
iw))
-(defun factor-calculate-indentation ()
+(defsubst factor--ppss-brackets-depth ()
+ (nth 0 (syntax-ppss)))
+
+(defsubst factor--ppss-brackets-start ()
+ (nth 1 (syntax-ppss)))
+
+(defsubst factor--line-indent (pos)
+ (save-excursion (goto-char pos) (current-indentation)))
+
+(defconst factor--regex-closing-paren "[])}]")
+(defsubst factor--at-closing-paren-p ()
+ (looking-at factor--regex-closing-paren))
+
+(defsubst factor--at-first-char-p ()
+ (= (- (point) (line-beginning-position)) (current-indentation)))
+
+(defconst factor--regex-single-liner
+ (format "^%s" (regexp-opt '("USE:" "IN:" "PRIVATE>" "<PRIVATE"))))
+
+(defun factor--at-end-of-def ()
+ (or (looking-at ".*;[ \t]*$")
+ (looking-at factor--regex-single-liner)))
+
+(defun factor--indent-in-brackets ()
+ (save-excursion
+ (beginning-of-line)
+ (when (or (and (re-search-forward factor--regex-closing-paren
+ (line-end-position) t)
+ (not (backward-char)))
+ (> (factor--ppss-brackets-depth) 0))
+ (let ((op (factor--ppss-brackets-start)))
+ (when (> (line-number-at-pos) (line-number-at-pos op))
+ (if (factor--at-closing-paren-p)
+ (factor--line-indent op)
+ (+ (factor--line-indent op) factor-indent-width)))))))
+
+(defun factor--indent-definition ()
+ (save-excursion
+ (beginning-of-line)
+ (when (looking-at "\\([^ ]\\|^\\)+:") 0)))
+
+(defun factor--indent-continuation ()
+ (save-excursion
+ (forward-line -1)
+ (beginning-of-line)
+ (if (bobp) 0
+ (if (looking-at "^[ \t]*$")
+ (factor--indent-continuation)
+ (if (factor--at-end-of-def)
+ (- (current-indentation) factor-indent-width)
+ (if (factor--indent-definition)
+ (+ (current-indentation) factor-indent-width)
+ (current-indentation)))))))
+
+(defun factor--calculate-indentation ()
"Calculate Factor indentation for line at point."
- (let ((not-indented t)
- (cur-indent 0))
- (save-excursion
- (beginning-of-line)
- (if (bobp)
- (setq cur-indent 0)
- (save-excursion
- (while not-indented
- ;; Check that we are inside open brackets
- (save-excursion
- (let ((cur-depth (factor-brackets-depth)))
- (forward-line -1)
- (setq cur-indent (+ (current-indentation)
- (* factor-indent-width
- (- cur-depth (factor-brackets-depth)))))
- (setq not-indented nil)))
- (forward-line -1)
- ;; Check that we are after the end of previous word
- (if (looking-at ".*;[ \t]*$")
- (progn
- (setq cur-indent (- (current-indentation) factor-indent-width))
- (setq not-indented nil))
- ;; Check that we are after the start of word
- (if (looking-at (factor-word-start-re factor-word-starting-keywords))
-; (if (looking-at "^[A-Z:]*: ")
- (progn
- (message "inword")
- (setq cur-indent (+ (current-indentation) factor-indent-width))
- (setq not-indented nil))
- (if (bobp)
- (setq not-indented nil))))))))
- cur-indent))
-
-(defun factor-brackets-depth ()
- "Returns number of brackets, not closed on previous lines."
- (syntax-ppss-depth
- (save-excursion
- (syntax-ppss (line-beginning-position)))))
+ (or (and (bobp) 0)
+ (factor--indent-definition)
+ (factor--indent-in-brackets)
+ (factor--indent-continuation)
+ 0))
(defun factor-indent-line ()
"Indent current line as Factor code"
- (let ((target (factor-calculate-indentation))
+ (let ((target (factor--calculate-indentation))
(pos (- (point-max) (point))))
(if (= target (current-indentation))
(if (< (current-column) (current-indentation))
(if (> (- (point-max) pos) (point))
(goto-char (- (point-max) pos))))))
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; factor-mode
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+\f
+;; Factor mode:
+;;;###autoload
(defun factor-mode ()
"A mode for editing programs written in the Factor programming language.
\\{factor-mode-map}"
(add-to-list 'auto-mode-alist '("\\.factor\\'" . factor-mode))
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; factor-listener-mode
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+\f
+;;; Factor listener mode
+;;;###autoload
(define-derived-mode factor-listener-mode comint-mode "Factor Listener")
(define-key factor-listener-mode-map [f8] 'factor-refresh-all)
+;;;###autoload
(defun run-factor ()
+ "Start a factor listener inside emacs, or switch to it if it
+already exists."
(interactive)
(switch-to-buffer
(make-comint-in-buffer "factor" nil (expand-file-name factor-binary) nil
(factor-listener-mode))
(defun factor-refresh-all ()
+ "Reload source files and documentation for all loaded
+vocabularies which have been modified on disk."
(interactive)
(comint-send-string "*factor*" "refresh-all\n"))
+
+\f
+
+(provide 'factor)
+;;; factor.el ends here
--- /dev/null
+Eduardo Cavazos
--- /dev/null
+Eduardo Cavazos
--- /dev/null
+USING: kernel combinators sequences math math.functions math.vectors mortar
+ slot-accessors x x.widgets.wm.root x.widgets.wm.frame sequences.lib ;
+IN: factory.commands
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: up-till-frame ( window -- wm-frame )
+{ { [ dup <wm-frame> is? ]
+ [ ] }
+ { [ dup $dpy $default-root $id over $id = ]
+ [ drop f ] }
+ { [ t ]
+ [ <- parent up-till-frame ] } } cond ;
+
+: pointer-window ( -- window ) dpy> <- pointer-window ;
+
+: pointer-frame ( -- wm-frame )
+pointer-window up-till-frame dup <wm-frame> is? [ ] [ drop f ] if ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: maximize ( -- ) pointer-frame wm-frame-maximize drop ;
+
+: minimize ( -- ) pointer-frame <- unmap drop ;
+
+: maximize-vertical ( -- ) pointer-frame wm-frame-maximize-vertical drop ;
+
+: restore ( -- ) pointer-frame <- restore-state drop ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+
+
+: tile-master ( -- )
+
+wm-root>
+ <- children
+ [ <- mapped? ] filter
+ [ check-window-table ] map
+ reverse
+
+unclip
+ { 0 0 } <-- move
+ wm-root> <- size { 1/2 1 } v*
+ [ floor ] map <-- resize
+ <- adjust-child
+drop
+
+dup empty? [ drop ] [
+
+wm-root> <- width 2 / floor [ <-- set-width ] curry map
+wm-root> <- height over length / floor [ <-- set-height ] curry map
+
+wm-root> <- width 2 / floor [ <-- set-x ] curry map
+
+wm-root> <- height over length / over length [ * floor ] map-with
+[ <-- set-y <- adjust-child ] 2map
+
+drop
+
+] if ;
+
+! : tile-master ( -- )
+
+! wm-root>
+! <- children
+! [ <- mapped? ] filter
+! [ check-window-table ] map
+! reverse
+
+! { { [ dup empty? ] [ drop ] }
+! { [ dup length 1 = ] [ drop maximize ] }
+! { [ t ] [ tile-master* ] }
--- /dev/null
+! -*-factor-*-
+
+USING: kernel unix vars mortar mortar.sugar slot-accessors
+ x.widgets.wm.menu x.widgets.wm.unmapped-frames-menu
+ factory.commands factory.load ;
+
+IN: factory
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! Helper words
+
+: new-wm-menu ( -- menu ) <wm-menu> new* 1 <-- set-border-width ;
+
+: shrink-wrap ( menu -- ) dup <- calc-size <-- resize drop ;
+
+: set-menu-items ( items menu -- ) swap >>items shrink-wrap ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+VAR: apps-menu
+
+apps-menu> not [ new-wm-menu >apps-menu ] when
+
+{ { "Emacs" [ "emacs &" system drop ] }
+ { "KMail" [ "kmail &" system drop ] }
+ { "Akregator" [ "akregator &" system drop ] }
+ { "Amarok" [ "amarok &" system drop ] }
+ { "K3b" [ "k3b &" system drop ] }
+ { "xchat" [ "xchat &" system drop ] }
+ { "Nautilus" [ "nautilus --no-desktop &" system drop ] }
+ { "synaptic" [ "gksudo synaptic &" system drop ] }
+ { "Volume control" [ "gnome-volume-control &" system drop ] }
+ { "Azureus" [ "~/azureus/azureus &" system drop ] }
+ { "Xephyr" [ "Xephyr -host-cursor :1 &" system drop ] }
+ { "Stop Xephyr" [ "pkill Xephyr &" system drop ] }
+ { "Stop Firefox" [ "pkill firefox &" system drop ] }
+} apps-menu> set-menu-items
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+VAR: emacs-menu
+
+emacs-menu> not [ new-wm-menu >emacs-menu ] when
+
+{ { "Start Emacs" [ "emacs &" system drop ] }
+ { "Small" [ "emacsclient -e '(make-small-frame-command)' &" system drop ] }
+ { "Large" [ "emacsclient -e '(make-frame-command)' &" system drop ] }
+ { "Full" [ "emacsclient -e '(make-full-frame-command)' &" system drop ] }
+ { "Gnus" [ "emacsclient -e '(gnus-other-frame)' &" system drop ] }
+ { "Factor" [ "emacsclient -e '(run-factor-other-frame)' &" system drop ] }
+} emacs-menu> set-menu-items
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+VAR: mail-menu
+
+mail-menu> not [ new-wm-menu >mail-menu ] when
+
+{ { "Kmail" [ "kmail &" system drop ] }
+ { "compose" [ "kmail --composer &" system drop ] }
+ { "slava" [ "kmail slava@factorcode.org &" system drop ] }
+ { "erg" [ "kmail doug.coleman@gmail.com &" system drop ] }
+ { "doublec" [ "kmail chris.double@double.co.nz &" system drop ] }
+ { "yuuki" [ "kmail matthew.willis@mac.com &" system drop ] }
+} mail-menu> set-menu-items
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+VAR: factor-menu
+
+factor-menu> not [ new-wm-menu >factor-menu ] when
+
+{ { "Factor" [ "cd /scratch/repos/Factor ; ./factor &" system drop ] }
+ { "Factor (tty)"
+ [ "cd /scratch/repos/Factor ; xterm -e ./factor -run=listener &"
+ system drop ] }
+ { "Terminal : repos/Factor"
+ [ "cd /scratch/repos/Factor ; xterm &" system drop ] }
+ { "darcs whatsnew"
+ [ "cd /scratch/repos/Factor ; xterm -e 'darcs whatsnew | less' &"
+ system drop ] }
+ { "darcs pull"
+ [ "cd /scratch/repos/Factor ; xterm -e 'darcs pull http://factorcode.org/repos' &" system drop ] }
+ { "darcs push"
+ [ "cd /scratch/repos/Factor ; xterm -e 'darcs push dharmatech@onigirihouse.com:doc-root/repos' &" system drop ] }
+} factor-menu> set-menu-items
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+VAR: factory-menu
+
+factory-menu> not [ new-wm-menu >factory-menu ] when
+
+{ { "Maximize" [ maximize ] }
+ { "Maximize Vertical" [ maximize-vertical ] }
+ { "Restore" [ restore ] }
+ { "Hide" [ minimize ] }
+ { "Tile Master" [ tile-master ] }
+}
+
+factory-menu> set-menu-items
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! VAR: root-menu
+
+{ { "xterm" [ "urxvt -bd grey +sb &" system drop ] }
+ { "Firefox" [ "firefox &" system drop ] }
+ { "xclock" [ "xclock &" system drop ] }
+ { "Apps >" [ apps-menu> <- popup ] }
+ { "Factor >" [ factor-menu> <- popup ] }
+ { "Unmapped frames >" [ unmapped-frames-menu> <- popup ] }
+ { "Emacs >" [ emacs-menu> <- popup ] }
+ { "Mail >" [ mail-menu> <- popup ] }
+ { "onigirihouse" [ "xterm -e 'ssh dharmatech@onigirihouse.com' &"
+ system drop ] }
+ { "Edit menus" [ edit-factory-menus ] }
+ { "Reload menus" [ load-factory-menus ] }
+ { "Factory >" [ factory-menu> <- popup ] }
+} root-menu> set-menu-items
+
--- /dev/null
+! -*-factor-*-
+
+USING: kernel mortar x
+ x.widgets.wm.root
+ x.widgets.wm.workspace
+ x.widgets.wm.unmapped-frames-menu
+ factory.load
+ tty-server ;
+
+IN: factory
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+create-root-menu
+create-unmapped-frames-menu
+load-factory-menus
+6 setup-workspaces
+
+wm-root>
+ no-modifiers "F12" [ root-menu> <- popup ] <---- set-key-action
+ control-alt "LEFT" [ prev-workspace ] <---- set-key-action
+ control-alt "RIGHT" [ next-workspace ] <---- set-key-action
+ alt "TAB" [ circulate-focus ] <---- set-key-action
+drop
+
+9010 tty-server
--- /dev/null
+
+USING: kernel parser io io.files namespaces sequences editors threads vars
+ mortar mortar.sugar slot-accessors
+ x
+ x.widgets.wm.root
+ x.widgets.wm.frame
+ x.widgets.wm.menu
+ factory.load
+ factory.commands ;
+
+IN: factory
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: manage-windows ( -- )
+dpy get $default-root <- children [ <- mapped? ] filter
+[ $id <wm-frame> new* drop ] each ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+VAR: root-menu
+
+: create-root-menu ( -- ) <wm-menu> new* 1 <-- set-border-width >root-menu ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: start-factory ( display-string -- )
+<display> new* >dpy
+install-default-error-handler
+create-wm-root
+init-atoms
+manage-windows
+load-factory-rc ;
+
+: factory ( -- ) f start-factory stop ;
+
+MAIN: factory
\ No newline at end of file
--- /dev/null
+Eduardo Cavazos
--- /dev/null
+
+USING: kernel io.files parser editors sequences ;
+
+IN: factory.load
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: file-or ( file file -- file ) over exists? [ drop ] [ nip ] if ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: personal-factory-rc ( -- path ) home "/.factory-rc" append ;
+
+: system-factory-rc ( -- path ) "extra/factory/factory-rc" resource-path ;
+
+: factory-rc ( -- path ) personal-factory-rc system-factory-rc file-or ;
+
+: load-factory-rc ( -- ) factory-rc run-file ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: personal-factory-menus ( -- path ) home "/.factory-menus" append ;
+
+: system-factory-menus ( -- path )
+"extra/factory/factory-menus" resource-path ;
+
+: factory-menus ( -- path )
+personal-factory-menus system-factory-menus file-or ;
+
+: load-factory-menus ( -- ) factory-menus run-file ;
+
+: edit-factory-menus ( -- ) factory-menus 0 edit-location ;
--- /dev/null
+Window manager for the X Window System
--- /dev/null
+applications
--- /dev/null
+Eduardo Cavazos
--- /dev/null
+
+USING: sequences mortar slot-accessors ;
+
+IN: geom.dim
+
+SYMBOL: <dim>
+
+<dim> { "dim" } accessors define-independent-class
+
+<dim> {
+
+"width" !( dim -- width ) [ $dim first ]
+
+"height" !( dim -- second ) [ $dim second ]
+
+} add-methods
\ No newline at end of file
--- /dev/null
+Eduardo Cavazos
--- /dev/null
+
+USING: kernel arrays sequences math.vectors mortar slot-accessors ;
+
+IN: geom.pos
+
+SYMBOL: <pos>
+
+<pos> { "pos" } accessors define-independent-class
+
+<pos> {
+
+"x" !( pos -- x ) [ $pos first ]
+
+"y" !( pos -- y ) [ $pos second ]
+
+"set-x" !( pos x -- pos ) [ 0 pick $pos set-nth ]
+
+"set-y" !( pos y -- pos ) [ 1 pick $pos set-nth ]
+
+"distance" !( pos pos -- distance ) [ $pos swap $pos v- norm ]
+
+"move-by" !( pos offset -- pos ) [ over $pos v+ >>pos ]
+
+"move-by-x" !( pos x-offset -- pos ) [ 0 2array <-- move-by ]
+
+"move-by-y" !( pos y-offset -- pos ) [ 0 swap 2array <-- move-by ]
+
+} add-methods
\ No newline at end of file
--- /dev/null
+Eduardo Cavazos
--- /dev/null
+
+USING: kernel namespaces arrays sequences math.vectors
+ mortar slot-accessors geom.pos geom.dim ;
+
+IN: geom.rect
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+USE: math
+
+: v+y ( pos y -- pos ) 0 swap 2array v+ ;
+
+: v-y ( pos y -- pos ) 0 swap 2array v- ;
+
+: v+x ( pos x -- pos ) 0 2array v+ ;
+
+: v-x ( pos x -- pos ) 0 2array v- ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+SYMBOL: <rect>
+
+<rect>
+ <pos> class-slots <dim> class-slots append
+ <pos> class-methods <dim> class-methods append { H{ } } append
+ { H{ } }
+4array <rect> set-global
+
+! { 0 0 } { 0 0 } <rect> new
+
+<rect> {
+
+"top-left" !( rect -- point ) [ $pos ]
+
+"top-right" !( rect -- point ) [ dup $pos swap <- width 1- v+x ]
+
+"bottom-left" !( rect -- point ) [ dup $pos swap <- height 1- v+y ]
+
+"bottom-right" !( rect -- point ) [ dup $pos swap $dim { 1 1 } v- v+ ]
+
+} add-methods
\ No newline at end of file
--- /dev/null
+Eduardo Cavazos
--- /dev/null
+
+USING: kernel io parser lexer words namespaces quotations arrays assocs sequences
+ splitting grouping math generalizations ;
+
+IN: mortar
+
+! class { name slots methods class-methods }
+
+: class-name ( class -- name ) dup symbol? [ get ] when first ;
+
+: class-slots ( class -- slots ) dup symbol? [ get ] when second ;
+
+: class-methods ( class -- methods ) dup symbol? [ get ] when third ;
+
+: class-class-methods ( class -- methods ) dup symbol? [ get ] when fourth ;
+
+: class? ( thing -- ? )
+dup array?
+[ dup length 4 = [ first symbol? ] [ drop f ] if ]
+[ drop f ]
+if ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: add-method ( class name quot -- )
+rot get class-methods peek swapd set-at ;
+
+: add-class-method ( class name quot -- )
+rot get class-class-methods peek swapd set-at ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! object { class values }
+
+: object-class ( object -- class ) first ;
+
+: object-values ( object -- values ) second ;
+
+: object? ( thing -- ? )
+dup array?
+[ dup length 2 = [ first class? ] [ drop f ] if ]
+[ drop f ]
+if ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: is? ( object class -- ? ) swap object-class class-name = ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: new ( class -- object )
+get dup >r class-slots length narray r> swap 2array ;
+
+: new-empty ( class -- object )
+get dup >r class-slots length f <array> r> swap 2array ;
+
+! : new* ( class -- object ) new-empty <- init ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: slot-value ( object slot -- value )
+over object-class class-slots index swap object-values nth ;
+
+: set-slot-value ( object slot value -- object )
+swap pick object-class class-slots index pick object-values set-nth ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! : send-message ( object message -- )
+! over object-class class-methods assoc-stack call ;
+
+: send-message ( object message -- )
+2dup swap object-class class-methods assoc-stack dup
+[ nip call ]
+! [ drop nip "message not understood: " write print flush ]
+[ drop "message not understood: " write print drop ]
+if ;
+
+: <- scan parsed \ send-message parsed ; parsing
+
+! : send-message* ( message n -- )
+! 1+ npick object-class class-methods assoc-stack call ;
+
+: send-message* ( message n -- )
+1+ npick dupd object-class class-methods assoc-stack dup
+[ nip call ]
+[ drop "message not understood: " write print flush ]
+if ;
+
+: <-- scan parsed 2 parsed \ send-message* parsed ; parsing
+
+: <--- scan parsed 3 parsed \ send-message* parsed ; parsing
+
+: <---- scan parsed 4 parsed \ send-message* parsed ; parsing
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: send-message-to-class ( class message -- )
+over class-class-methods assoc-stack call ;
+
+: <<- scan parsed \ send-message-to-class parsed ; parsing
+
+: send-message-to-class* ( message n -- )
+1+ npick class-class-methods assoc-stack call ;
+
+: <<-- scan parsed 2 parsed \ send-message-to-class* parsed ; parsing
+
+: <<--- scan parsed 3 parsed \ send-message-to-class* parsed ; parsing
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: send-message-next ( object message -- )
+over object-class class-methods but-last assoc-stack call ;
+
+: <-~ scan parsed \ send-message-next parsed ; parsing
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! : new* ( class -- object ) <<- create ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+IN: slot-accessors
+
+IN: mortar
+
+! : generate-slot-getter ( name -- )
+! "$" over append "slot-accessors" create swap [ slot-value ] curry
+! define-compound ;
+
+: generate-slot-getter ( name -- )
+"$" over append "slot-accessors" create swap [ slot-value ] curry define ;
+
+! : generate-slot-setter ( name -- )
+! ">>" over append "slot-accessors" create swap [ swap set-slot-value ] curry
+! define-compound ;
+
+: generate-slot-setter ( name -- )
+">>" over append "slot-accessors" create swap [ swap set-slot-value ] curry
+define ;
+
+: generate-slot-accessors ( name -- )
+dup
+generate-slot-getter
+generate-slot-setter ;
+
+: accessors ( seq -- seq ) dup peek [ generate-slot-accessors ] each ; parsing
+
+! : slots:
+! ";" parse-tokens dup [ generate-slot-accessors ] each parsed ; parsing
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! : <symbol> ( string -- symbol ) in get create dup define-symbol ;
+
+: empty-method-table ( -- array ) H{ } clone 1array ;
+
+! : define-simple-class ( name parent slots -- )
+! >r >r <symbol>
+! r> dup class-slots r> append
+! swap dup class-methods empty-method-table append
+! swap class-class-methods empty-method-table append
+! 4array dup first set-global ;
+
+: define-simple-class ( name parent slots -- )
+>r dup class-slots r> append
+swap dup class-methods empty-method-table append
+swap class-class-methods empty-method-table append
+4array dup first set-global ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: define-independent-class ( name slots -- )
+empty-method-table empty-method-table 4array dup first set-global ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: add-methods ( class seq -- ) 2 group [ first2 add-method ] with each ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: !( ")" parse-tokens drop ; parsing
\ No newline at end of file
--- /dev/null
+
+USING: mortar ;
+
+IN: mortar.sugar
+
+: new* ( class -- object ) <<- create ;
\ No newline at end of file
--- /dev/null
+extensions
--- /dev/null
+Chris Double
--- /dev/null
+! Copyright (C) 2007 Chris Double.\r
+! See http://factorcode.org/license.txt for BSD license.\r
+USING: help.syntax help.markup threads ;\r
+\r
+IN: odbc\r
+\r
+HELP: odbc-init \r
+{ $values { "env" "an ODBC environment handle" } } \r
+{ $description \r
+ "Initializes the ODBC driver manager and returns the " \r
+ "environment handle required by " { $link odbc-connect } "."\r
+} \r
+{ $see-also odbc-init odbc-connect odbc-disconnect odbc-prepare odbc-free-statement odbc-execute odbc-next-row odbc-number-of-columns odbc-describe-column odbc-get-field odbc-get-row-fields odbc-get-all-rows odbc-query } ;\r
+\r
+HELP: odbc-connect \r
+{ $values { "env" "an ODBC environment handle" } { "dsn" "a string" } { "dbc" "an ODBC database connection handle" } } \r
+{ $description \r
+ "Connects to the database identified by the ODBC data source name (DSN). " \r
+ "The environment handle is usually obtained by a call to " { $link odbc-init } ". The result is the ODBC connection handle which can be used in other ODBC calls. When finished with the connection handle " { $link odbc-disconnect } " must be called on it."\r
+} \r
+{ $examples { $code "dbc get \"DSN=mydsn\" odbc-connect" } }\r
+{ $see-also odbc-init odbc-connect odbc-disconnect odbc-prepare odbc-free-statement odbc-execute odbc-next-row odbc-number-of-columns odbc-describe-column odbc-get-field odbc-get-row-fields odbc-get-all-rows odbc-query } ;\r
+\r
+HELP: odbc-disconnect \r
+{ $values { "dbc" "an ODBC database connection handle" } } \r
+{ $description \r
+ "Disconnects from the given database." \r
+} \r
+{ $see-also odbc-init odbc-connect odbc-disconnect odbc-prepare odbc-free-statement odbc-execute odbc-next-row odbc-number-of-columns odbc-describe-column odbc-get-field odbc-get-row-fields odbc-get-all-rows odbc-query } ;\r
+\r
+HELP: odbc-prepare\r
+{ $values { "dbc" "an ODBC database connection handle" } { "string" "a string containing SQL" } { "statement" "an ODBC statement handle" } } \r
+{ $description \r
+ "Prepares (precompiles) the given SQL string, ready for execution with " { $link odbc-execute } ". When finished with the statement " { $link odbc-free-statement } " must be called on it." \r
+} \r
+{ $see-also odbc-init odbc-connect odbc-disconnect odbc-prepare odbc-free-statement odbc-execute odbc-next-row odbc-number-of-columns odbc-describe-column odbc-get-field odbc-get-row-fields odbc-get-all-rows odbc-query } ;\r
+\r
+HELP: odbc-free-statement\r
+{ $values { "statement" "an ODBC statement handle" } } \r
+{ $description \r
+ "Closes the statement handle and frees up all resources associated with it." \r
+} \r
+{ $see-also odbc-init odbc-connect odbc-disconnect odbc-prepare odbc-free-statement odbc-execute odbc-next-row odbc-number-of-columns odbc-describe-column odbc-get-field odbc-get-row-fields odbc-get-all-rows odbc-query } ;\r
+\r
+HELP: odbc-execute\r
+{ $values { "statement" "an ODBC statement handle" } } \r
+{ $description \r
+ "Executes the statement. Once this is done " { $link odbc-next-row } " can be called to retrieve rows." \r
+} \r
+{ $see-also odbc-init odbc-connect odbc-disconnect odbc-prepare odbc-free-statement odbc-execute odbc-next-row odbc-number-of-columns odbc-describe-column odbc-get-field odbc-get-row-fields odbc-get-all-rows odbc-query } ;\r
+\r
+HELP: odbc-next-row\r
+{ $values { "statement" "an ODBC statement handle" } { "bool" "a boolean indicating success or failure" } } \r
+{ $description \r
+ "Retrieves the next available row from the database. If no next row is available then " { $link f } " is returned. Once the row is retrieved " { $link odbc-number-of-columns } ", " { $link odbc-describe-column } ", " { $link odbc-get-field } " and " { $link odbc-get-row-fields } " can be used to query the data retrieved." \r
+} \r
+{ $see-also odbc-init odbc-connect odbc-disconnect odbc-prepare odbc-free-statement odbc-execute odbc-next-row odbc-number-of-columns odbc-describe-column odbc-get-field odbc-get-row-fields odbc-get-all-rows odbc-query } ;\r
+\r
+HELP: odbc-number-of-columns\r
+{ $values { "statement" "an ODBC statement handle" } { "number" "a number" } } \r
+{ $description \r
+ "Returns the number of columns of data retrieved."\r
+} \r
+{ $see-also odbc-init odbc-connect odbc-disconnect odbc-prepare odbc-free-statement odbc-execute odbc-next-row odbc-number-of-columns odbc-describe-column odbc-get-field odbc-get-row-fields odbc-get-all-rows odbc-query } ;\r
+\r
+HELP: odbc-describe-column\r
+{ $values { "statement" "an ODBC statement handle" } { "n" "a column number starting from one" } { "column" "a column object" } } \r
+{ $description \r
+ "Retrieves column information for the given column number from the statement. The column number must be one or greater. The " { $link <column> } " object returned provides data type, name, etc."\r
+} \r
+{ $see-also odbc-init odbc-connect odbc-disconnect odbc-prepare odbc-free-statement odbc-execute odbc-next-row odbc-number-of-columns odbc-describe-column odbc-get-field odbc-get-row-fields odbc-get-all-rows odbc-query } ;\r
+\r
+HELP: odbc-get-field\r
+{ $values { "statement" "an ODBC statement handle" } { "column" "a column number starting from one or a <column> object" } { "field" "a <field> object" } } \r
+{ $description \r
+ "Returns a field object which contains the data for the field in the given column in the current row. The column can be identified by a number or a <column> object. The datatype of the contents of the field depends on the type of the column itself. Note that this word can only be safely called once on each column in a given row with most ODBC drivers. Subsequent calls on the same row for the same column can fail."\r
+} \r
+{ $see-also odbc-init odbc-connect odbc-disconnect odbc-prepare odbc-free-statement odbc-execute odbc-next-row odbc-number-of-columns odbc-describe-column odbc-get-field odbc-get-row-fields odbc-get-all-rows odbc-query } ;\r
+\r
+HELP: odbc-get-row-fields\r
+{ $values { "statement" "an ODBC statement handle" } { "seq" "a sequence" } } \r
+{ $description \r
+ "Returns a sequence of all field data for the current row. Note that this isnot the <field> objects, but the data for that field. This word can only be called once on a given row. Subsequent calls on the same row may fail on some ODBC drivers."\r
+} \r
+{ $see-also odbc-init odbc-connect odbc-disconnect odbc-prepare odbc-free-statement odbc-execute odbc-next-row odbc-number-of-columns odbc-describe-column odbc-get-field odbc-get-row-fields odbc-get-all-rows odbc-query } ;\r
+\r
+HELP: odbc-get-all-rows\r
+{ $values { "statement" "an ODBC statement handle" } { "seq" "a sequence" } } \r
+{ $description \r
+ "Returns a sequence of all rows available from the statement. Effectively it is the contents of the entire query so may take some time and memory. Each element of the sequence is itself a sequence containing the data for that row. A " { $link yield } " is performed an various intervals so as to not lock up the Factor instance while it is running."\r
+} \r
+{ $see-also odbc-init odbc-connect odbc-disconnect odbc-prepare odbc-free-statement odbc-execute odbc-next-row odbc-number-of-columns odbc-describe-column odbc-get-field odbc-get-row-fields odbc-get-all-rows odbc-query } ;\r
+\r
+HELP: odbc-query\r
+{ $values { "string" "a string containing SQL" } { "dsn" "a DSN string" } { "result" "a sequence" } } \r
+{ $description \r
+ "This word initializes odbc, connects to the database with the given DSN, executes the query string and returns the result as a sequence. It cleans up all resources it uses. It is an inefficient way of running multiple queries but is useful for the occasional query, testing at the REPL, or as an example of how to do it."\r
+} \r
+{ $see-also odbc-init odbc-connect odbc-disconnect odbc-prepare odbc-free-statement odbc-execute odbc-next-row odbc-number-of-columns odbc-describe-column odbc-get-field odbc-get-row-fields odbc-get-all-rows odbc-query } ;\r
--- /dev/null
+! Copyright (C) 2007 Chris Double.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel alien alien.strings alien.syntax
+combinators alien.c-types strings sequences namespaces make
+words math threads io.encodings.ascii ;
+IN: odbc
+
+<< "odbc" "odbc32.dll" "stdcall" add-library >>
+
+LIBRARY: odbc
+
+TYPEDEF: void* usb_dev_handle*
+TYPEDEF: short SQLRETURN
+TYPEDEF: short SQLSMALLINT
+TYPEDEF: short* SQLSMALLINT*
+TYPEDEF: ushort SQLUSMALLINT
+TYPEDEF: uint* SQLUINTEGER*
+TYPEDEF: int SQLINTEGER
+TYPEDEF: char SQLCHAR
+TYPEDEF: char* SQLCHAR*
+TYPEDEF: void* SQLHANDLE
+TYPEDEF: void* SQLHANDLE*
+TYPEDEF: void* SQLHENV
+TYPEDEF: void* SQLHDBC
+TYPEDEF: void* SQLHSTMT
+TYPEDEF: void* SQLHWND
+TYPEDEF: void* SQLPOINTER
+
+: SQL-HANDLE-ENV ( -- number ) 1 ; inline
+: SQL-HANDLE-DBC ( -- number ) 2 ; inline
+: SQL-HANDLE-STMT ( -- number ) 3 ; inline
+: SQL-HANDLE-DESC ( -- number ) 4 ; inline
+
+: SQL-NULL-HANDLE ( -- alien ) f ; inline
+
+: SQL-ATTR-ODBC-VERSION ( -- number ) 200 ; inline
+
+: SQL-OV-ODBC2 ( -- number ) 2 <alien> ; inline
+: SQL-OV-ODBC3 ( -- number ) 3 <alien> ; inline
+
+: SQL-SUCCESS ( -- number ) 0 ; inline
+: SQL-SUCCESS-WITH-INFO ( -- number ) 1 ; inline
+: SQL-NO-DATA-FOUND ( -- number ) 100 ; inline
+
+: SQL-DRIVER-NOPROMPT ( -- number ) 0 ; inline
+: SQL-DRIVER-PROMPT ( -- number ) 2 ; inline
+
+: SQL-C-DEFAULT ( -- number ) 99 ; inline
+
+SYMBOL: SQL-CHAR
+SYMBOL: SQL-VARCHAR
+SYMBOL: SQL-LONGVARCHAR
+SYMBOL: SQL-WCHAR
+SYMBOL: SQL-WCHARVAR
+SYMBOL: SQL-WLONGCHARVAR
+SYMBOL: SQL-DECIMAL
+SYMBOL: SQL-SMALLINT
+SYMBOL: SQL-NUMERIC
+SYMBOL: SQL-INTEGER
+SYMBOL: SQL-REAL
+SYMBOL: SQL-FLOAT
+SYMBOL: SQL-DOUBLE
+SYMBOL: SQL-BIT
+SYMBOL: SQL-TINYINT
+SYMBOL: SQL-BIGINT
+SYMBOL: SQL-BINARY
+SYMBOL: SQL-VARBINARY
+SYMBOL: SQL-LONGVARBINARY
+SYMBOL: SQL-TYPE-DATE
+SYMBOL: SQL-TYPE-TIME
+SYMBOL: SQL-TYPE-TIMESTAMP
+SYMBOL: SQL-TYPE-UTCDATETIME
+SYMBOL: SQL-TYPE-UTCTIME
+SYMBOL: SQL-INTERVAL-MONTH
+SYMBOL: SQL-INTERVAL-YEAR
+SYMBOL: SQL-INTERVAL-YEAR-TO-MONTH
+SYMBOL: SQL-INTERVAL-DAY
+SYMBOL: SQL-INTERVAL-HOUR
+SYMBOL: SQL-INTERVAL-MINUTE
+SYMBOL: SQL-INTERVAL-SECOND
+SYMBOL: SQL-INTERVAL-DAY-TO-HOUR
+SYMBOL: SQL-INTERVAL-DAY-TO-MINUTE
+SYMBOL: SQL-INTERVAL-DAY-TO-SECOND
+SYMBOL: SQL-INTERVAL-HOUR-TO-MINUTE
+SYMBOL: SQL-INTERVAL-HOUR-TO-SECOND
+SYMBOL: SQL-INTERVAL-MINUTE-TO-SECOND
+SYMBOL: SQL-GUID
+SYMBOL: SQL-TYPE-UNKNOWN
+
+: convert-sql-type ( number -- symbol )
+ {
+ { 1 [ SQL-CHAR ] }
+ { 12 [ SQL-VARCHAR ] }
+ { -1 [ SQL-LONGVARCHAR ] }
+ { -8 [ SQL-WCHAR ] }
+ { -9 [ SQL-WCHARVAR ] }
+ { -10 [ SQL-WLONGCHARVAR ] }
+ { 3 [ SQL-DECIMAL ] }
+ { 5 [ SQL-SMALLINT ] }
+ { 2 [ SQL-NUMERIC ] }
+ { 4 [ SQL-INTEGER ] }
+ { 7 [ SQL-REAL ] }
+ { 6 [ SQL-FLOAT ] }
+ { 8 [ SQL-DOUBLE ] }
+ { -7 [ SQL-BIT ] }
+ { -6 [ SQL-TINYINT ] }
+ { -5 [ SQL-BIGINT ] }
+ { -2 [ SQL-BINARY ] }
+ { -3 [ SQL-VARBINARY ] }
+ { -4 [ SQL-LONGVARBINARY ] }
+ { 91 [ SQL-TYPE-DATE ] }
+ { 92 [ SQL-TYPE-TIME ] }
+ { 93 [ SQL-TYPE-TIMESTAMP ] }
+ [ drop SQL-TYPE-UNKNOWN ]
+ } case ;
+
+: succeeded? ( n -- bool )
+ #! Did the call succeed (SQL-SUCCESS or SQL-SUCCESS-WITH-INFO)
+ {
+ { SQL-SUCCESS [ t ] }
+ { SQL-SUCCESS-WITH-INFO [ t ] }
+ [ drop f ]
+ } case ;
+
+FUNCTION: SQLRETURN SQLAllocHandle ( SQLSMALLINT handleType, SQLHANDLE inputHandle, SQLHANDLE* outputHandlePtr ) ;
+FUNCTION: SQLRETURN SQLSetEnvAttr ( SQLHENV environmentHandle, SQLINTEGER attribute, SQLPOINTER valuePtr, SQLINTEGER stringLength ) ;
+FUNCTION: SQLRETURN SQLDriverConnect ( SQLHDBC connectionHandle, SQLHWND windowHandle, SQLCHAR* inConnectionString, SQLSMALLINT stringLength, SQLCHAR* outConnectionString, SQLSMALLINT bufferLength, SQLSMALLINT* stringLength2Ptr, SQLUSMALLINT driverCompletion ) ;
+FUNCTION: SQLRETURN SQLDisconnect ( SQLHDBC connectionHandle ) ;
+FUNCTION: SQLRETURN SQLPrepare ( SQLHSTMT statementHandle, SQLCHAR* statementText, SQLINTEGER length ) ;
+FUNCTION: SQLRETURN SQLExecute ( SQLHSTMT statementHandle ) ;
+FUNCTION: SQLRETURN SQLFreeHandle ( SQLSMALLINT handleType, SQLHANDLE handle ) ;
+FUNCTION: SQLRETURN SQLFetch ( SQLHSTMT statementHandle ) ;
+FUNCTION: SQLRETURN SQLNumResultCols ( SQLHSTMT statementHandle, SQLSMALLINT* columnCountPtr ) ;
+FUNCTION: SQLRETURN SQLDescribeCol ( SQLHSTMT statementHandle, SQLSMALLINT columnNumber, SQLCHAR* columnName, SQLSMALLINT bufferLength, SQLSMALLINT* nameLengthPtr, SQLSMALLINT* dataTypePtr, SQLUINTEGER* columnSizePtr, SQLSMALLINT* decimalDigitsPtr, SQLSMALLINT* nullablePtr ) ;
+FUNCTION: SQLRETURN SQLGetData ( SQLHSTMT statementHandle, SQLUSMALLINT columnNumber, SQLSMALLINT targetType, SQLPOINTER targetValuePtr, SQLINTEGER bufferLength, SQLINTEGER* strlen_or_indPtr ) ;
+
+: alloc-handle ( type parent -- handle )
+ f <void*> [ SQLAllocHandle ] keep swap succeeded? [
+ *void*
+ ] [
+ drop f
+ ] if ;
+
+: alloc-env-handle ( -- handle )
+ SQL-HANDLE-ENV SQL-NULL-HANDLE alloc-handle ;
+
+: alloc-dbc-handle ( env -- handle )
+ SQL-HANDLE-DBC swap alloc-handle ;
+
+: alloc-stmt-handle ( dbc -- handle )
+ SQL-HANDLE-STMT swap alloc-handle ;
+
+: temp-string ( length -- byte-array length )
+ [ CHAR: \space <string> ascii string>alien ] keep ;
+
+: odbc-init ( -- env )
+ alloc-env-handle
+ [
+ SQL-ATTR-ODBC-VERSION SQL-OV-ODBC3 0 SQLSetEnvAttr
+ succeeded? [ "odbc-init failed" throw ] unless
+ ] keep ;
+
+: odbc-connect ( env dsn -- dbc )
+ >r alloc-dbc-handle dup r>
+ f swap dup length 1024 temp-string 0 <short> SQL-DRIVER-NOPROMPT
+ SQLDriverConnect succeeded? [ "odbc-connect failed" throw ] unless ;
+
+: odbc-disconnect ( dbc -- )
+ SQLDisconnect succeeded? [ "odbc-disconnect failed" throw ] unless ;
+
+: odbc-prepare ( dbc string -- statement )
+ >r alloc-stmt-handle dup r> dup length SQLPrepare succeeded? [ "odbc-prepare failed" throw ] unless ;
+
+: odbc-free-statement ( statement -- )
+ SQL-HANDLE-STMT swap SQLFreeHandle succeeded? [ "odbc-free-statement failed" throw ] unless ;
+
+: odbc-execute ( statement -- )
+ SQLExecute succeeded? [ "odbc-execute failed" throw ] unless ;
+
+: odbc-next-row ( statement -- bool )
+ SQLFetch succeeded? ;
+
+: odbc-number-of-columns ( statement -- number )
+ 0 <short> [ SQLNumResultCols succeeded? ] keep swap [
+ *short
+ ] [
+ drop f
+ ] if ;
+
+TUPLE: column nullable digits size type name number ;
+
+C: <column> column
+
+: odbc-describe-column ( statement n -- column )
+ dup >r
+ 1024 CHAR: \space <string> ascii string>alien dup >r
+ 1024
+ 0 <short>
+ 0 <short> dup >r
+ 0 <uint> dup >r
+ 0 <short> dup >r
+ 0 <short> dup >r
+ SQLDescribeCol succeeded? [
+ r> *short
+ r> *short
+ r> *uint
+ r> *short convert-sql-type
+ r> ascii alien>string
+ r> <column>
+ ] [
+ r> drop r> drop r> drop r> drop r> drop r> drop
+ "odbc-describe-column failed" throw
+ ] if ;
+
+: dereference-type-pointer ( byte-array column -- object )
+ type>> {
+ { SQL-CHAR [ ascii alien>string ] }
+ { SQL-VARCHAR [ ascii alien>string ] }
+ { SQL-LONGVARCHAR [ ascii alien>string ] }
+ { SQL-WCHAR [ ascii alien>string ] }
+ { SQL-WCHARVAR [ ascii alien>string ] }
+ { SQL-WLONGCHARVAR [ ascii alien>string ] }
+ { SQL-SMALLINT [ *short ] }
+ { SQL-INTEGER [ *long ] }
+ { SQL-REAL [ *float ] }
+ { SQL-FLOAT [ *double ] }
+ { SQL-DOUBLE [ *double ] }
+ { SQL-TINYINT [ *char ] }
+ { SQL-BIGINT [ *longlong ] }
+ [ nip [ "Unknown SQL Type: " % name>> % ] "" make ]
+ } case ;
+
+TUPLE: field value column ;
+
+C: <field> field
+
+: odbc-get-field ( statement column -- field )
+ dup column? [ dupd odbc-describe-column ] unless dup >r number>>
+ SQL-C-DEFAULT
+ 8192 CHAR: \space <string> ascii string>alien dup >r
+ 8192
+ f SQLGetData succeeded? [
+ r> r> [ dereference-type-pointer ] keep <field>
+ ] [
+ r> drop r> [
+ "SQLGetData Failed for Column: " %
+ dup name>> %
+ " of type: " % dup type>> name>> %
+ ] "" make swap <field>
+ ] if ;
+
+: odbc-get-row-fields ( statement -- seq )
+ [
+ dup odbc-number-of-columns [
+ 1+ odbc-get-field value>> ,
+ ] with each
+ ] { } make ;
+
+: (odbc-get-all-rows) ( statement -- )
+ dup odbc-next-row [ dup odbc-get-row-fields , yield (odbc-get-all-rows) ] [ drop ] if ;
+
+: odbc-get-all-rows ( statement -- seq )
+ [ (odbc-get-all-rows) ] { } make ;
+
+: odbc-query ( string dsn -- result )
+ odbc-init swap odbc-connect [
+ swap odbc-prepare
+ dup odbc-execute
+ dup odbc-get-all-rows
+ swap odbc-free-statement
+ ] keep odbc-disconnect ;
--- /dev/null
+ODBC (Open DataBase Connectivity) binding
--- /dev/null
+
+USING: kernel sequences math math.order
+ ui.gadgets ui.gadgets.tracks ui.gestures
+ bake.fry accessors ;
+
+IN: ui.gadgets.tiling
+
+TUPLE: tiling < track gadgets tiles first focused ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: init-tiling ( tiling -- tiling )
+ init-track
+ { 1 0 } >>orientation
+ V{ } clone >>gadgets
+ 2 >>tiles
+ 0 >>first
+ 0 >>focused ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: <tiling> ( -- gadget ) tiling new init-tiling ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: bounded-subseq ( seq a b -- seq )
+ [ 0 max ] dip
+ pick length [ min ] curry bi@
+ rot
+ subseq ;
+
+: tiling-gadgets-to-map ( tiling -- gadgets )
+ [ gadgets>> ]
+ [ first>> ]
+ [ [ first>> ] [ tiles>> ] bi + ]
+ tri
+ bounded-subseq ;
+
+: tiling-map-gadgets ( tiling -- tiling )
+ dup clear-track
+ dup tiling-gadgets-to-map [ 1 track-add ] each ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: tiling-add ( tiling gadget -- tiling )
+ over gadgets>> push
+ tiling-map-gadgets ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: first-gadget ( tiling -- index ) drop 0 ;
+
+: last-gadget ( tiling -- index ) gadgets>> length 1 - ;
+
+: first-viewable ( tiling -- index ) first>> ;
+
+: last-viewable ( tiling -- index ) [ first>> ] [ tiles>> ] bi + 1 - ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: make-focused-mapped ( tiling -- tiling )
+
+ dup [ focused>> ] [ first>> ] bi <
+ [ dup first>> 1 - >>first ]
+ [ ]
+ if
+
+ dup [ last-viewable ] [ focused>> ] bi <
+ [ dup first>> 1 + >>first ]
+ [ ]
+ if ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: check-focused-bounds ( tiling -- tiling )
+ dup focused>> 0 max over gadgets>> length 1 - min >>focused ;
+
+: focus-prev ( tiling -- tiling )
+ dup focused>> 1 - >>focused
+ check-focused-bounds
+ make-focused-mapped
+ tiling-map-gadgets
+ dup request-focus ;
+
+: focus-next ( tiling -- tiling )
+ dup focused>> 1 + >>focused
+ check-focused-bounds
+ make-focused-mapped
+ tiling-map-gadgets
+ dup request-focus ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: exchanged! ( seq a b -- )
+ [ 0 max ] bi@
+ pick length 1 - '[ _ min ] bi@
+ rot exchange ;
+
+: move-prev ( tiling -- tiling )
+ dup [ gadgets>> ] [ focused>> 1 - ] [ focused>> ] tri exchanged!
+ focus-prev ;
+
+: move-next ( tiling -- tiling )
+ dup [ gadgets>> ] [ focused>> ] [ focused>> 1 + ] tri exchanged!
+ focus-next ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: add-tile ( tiling -- tiling )
+ dup tiles>> 1 + >>tiles
+ tiling-map-gadgets ;
+
+: del-tile ( tiling -- tiling )
+ dup tiles>> 1 - 1 max >>tiles
+ tiling-map-gadgets ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+M: tiling focusable-child* ( tiling -- child/t )
+ [ focused>> ] [ gadgets>> ] bi nth ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TUPLE: tiling-shelf < tiling ;
+TUPLE: tiling-pile < tiling ;
+
+: <tiling-shelf> ( -- gadget )
+ tiling-shelf new init-tiling { 1 0 } >>orientation ;
+
+: <tiling-pile> ( -- gadget )
+ tiling-pile new init-tiling { 0 1 } >>orientation ;
+
+tiling-shelf
+ H{
+ { T{ key-down f { A+ } "LEFT" } [ focus-prev drop ] }
+ { T{ key-down f { A+ } "RIGHT" } [ focus-next drop ] }
+ { T{ key-down f { S+ A+ } "LEFT" } [ move-prev drop ] }
+ { T{ key-down f { S+ A+ } "RIGHT" } [ move-next drop ] }
+ { T{ key-down f { C+ } "[" } [ del-tile drop ] }
+ { T{ key-down f { C+ } "]" } [ add-tile drop ] }
+ }
+set-gestures
+
+tiling-pile
+ H{
+ { T{ key-down f { A+ } "UP" } [ focus-prev drop ] }
+ { T{ key-down f { A+ } "DOWN" } [ focus-next drop ] }
+ { T{ key-down f { S+ A+ } "UP" } [ move-prev drop ] }
+ { T{ key-down f { S+ A+ } "DOWN" } [ move-next drop ] }
+ { T{ key-down f { C+ } "[" } [ del-tile drop ] }
+ { T{ key-down f { C+ } "]" } [ add-tile drop ] }
+ }
+set-gestures
--- /dev/null
+Eduardo Cavazos
--- /dev/null
+Eduardo Cavazos
--- /dev/null
+
+USING: kernel namespaces arrays sequences math x11.xlib
+ mortar slot-accessors x ;
+
+IN: x.font
+
+SYMBOL: <font>
+
+<font> { "dpy" "name" "id" "struct" } accessors define-independent-class
+
+<font> "create" !( name <font> -- font ) [
+new-empty swap >>name dpy get >>dpy
+dpy get $ptr over $name XLoadQueryFont >>struct
+dup $struct XFontStruct-fid >>id
+] add-class-method
+
+<font> {
+
+"ascent" !( font -- ascent ) [ $struct XFontStruct-ascent ]
+
+"descent" !( font -- ascent ) [ $struct XFontStruct-descent ]
+
+"height" !( font -- ascent ) [ dup <- ascent swap <- descent + ]
+
+"text-width" !( font string -- width ) [ >r $struct r> dup length XTextWidth ]
+
+} add-methods
\ No newline at end of file
--- /dev/null
+Eduardo Cavazos
--- /dev/null
+
+USING: kernel namespaces arrays x11.xlib mortar mortar.sugar
+ slot-accessors x x.font ;
+
+IN: x.gc
+
+SYMBOL: <gc>
+
+<gc> { "dpy" "ptr" "font" } accessors define-independent-class
+
+<gc> "create" !( <gc> -- gc ) [
+new-empty dpy get >>dpy
+dpy get $ptr dpy get $default-root $id 0 f XCreateGC >>ptr
+"6x13" <font> new* >>font
+] add-class-method
+
+<gc> {
+
+"set-subwindow-mode" !( gc mode -- gc )
+ [ >r dup $dpy $ptr over $ptr r> XSetSubwindowMode drop ]
+
+"set-function" !( gc function -- gc )
+ [ >r dup $dpy $ptr over $ptr r> XSetFunction drop ]
+
+"set-foreground" !( gc foreground -- gc )
+ [ >r dup $dpy $ptr over $ptr r> lookup-color XSetForeground drop ]
+
+} add-methods
\ No newline at end of file
--- /dev/null
+Eduardo Cavazos
--- /dev/null
+USING: kernel strings assocs sequences math ;
+
+IN: x.keysym-table
+
+: keysym-table ( -- table )
+H{ { HEX: FF08 "BACKSPACE" }
+ { HEX: FF09 "TAB" }
+ { HEX: FF0D "RETURN" }
+ { HEX: FF8D "ENTER" }
+ { HEX: FF1B "ESCAPE" }
+ { HEX: FFFF "DELETE" }
+ { HEX: FF50 "HOME" }
+ { HEX: FF51 "LEFT" }
+ { HEX: FF52 "UP" }
+ { HEX: FF53 "RIGHT" }
+ { HEX: FF54 "DOWN" }
+ { HEX: FF55 "PAGE-UP" }
+ { HEX: FF56 "PAGE-DOWN" }
+ { HEX: FF57 "END" }
+ { HEX: FF58 "BEGIN" }
+ { HEX: FFBE "F1" }
+ { HEX: FFBF "F2" }
+ { HEX: FFC0 "F3" }
+ { HEX: FFC1 "F4" }
+ { HEX: FFC2 "F5" }
+ { HEX: FFC3 "F6" }
+ { HEX: FFC4 "F7" }
+ { HEX: FFC5 "F8" }
+ { HEX: FFC6 "F9" }
+ { HEX: FFC7 "F10" }
+ { HEX: FFC8 "F11" }
+ { HEX: FFC9 "F12" }
+ { HEX: FFE1 "LEFT-SHIFT" }
+ { HEX: FFE2 "RIGHT-SHIFT" }
+ { HEX: FFE3 "LEFT-CONTROL" }
+ { HEX: FFE4 "RIGHT-CONTROL" }
+ { HEX: FFE5 "CAPSLOCK" }
+ { HEX: FFE9 "LEFT-ALT" }
+ { HEX: FFEA "RIGHT-ALT" }
+} ;
+
+: keysym>name ( keysym -- name )
+dup keysym-table at dup [ nip ] [ drop 1string ] if ;
+
+: name>keysym ( name -- keysym ) keysym-table value-at ;
--- /dev/null
+Eduardo Cavazos
--- /dev/null
+
+USING: kernel arrays math.vectors mortar mortar.sugar x.gc slot-accessors geom.pos ;
+
+IN: x.pen
+
+SYMBOL: <pen>
+
+<pen> <pos> { "window" "gc" } accessors define-simple-class
+
+<pen> "create" !( window <pen> -- pen )
+[ new-empty swap >>window <gc> new* >>gc 0 0 2array >>pos ]
+add-class-method
+
+<pen> {
+
+"line-to" ! ( pen point -- pen )
+ [ 2dup >r dup $window swap dup $gc swap $pos r> <---- draw-line >>pos ]
+
+"line-by" ! ( pen offset -- pen )
+ [ 2dup >r dup $window swap dup $gc swap $pos dup r> v+ <---- draw-line
+ <-- move-by ]
+
+"draw-string" ! ( pen string -- pen )
+ [ >r dup dup $window swap dup $gc swap $pos r> <---- draw-string ]
+
+} add-methods
\ No newline at end of file
--- /dev/null
+Eduardo Cavazos
--- /dev/null
+Eduardo Cavazos
--- /dev/null
+
+USING: kernel combinators math x11.xlib
+ mortar mortar.sugar slot-accessors x.gc x.widgets.label ;
+
+IN: x.widgets.button
+
+SYMBOL: <button>
+
+<button>
+ <label>
+ { "action-1" "action-2" "action-3" } accessors
+define-simple-class
+
+<button> "create" !( <button> -- button ) [
+new-empty
+<gc> new* >>gc ExposureMask ButtonPressMask bitor >>mask <- init-widget
+] add-class-method
+
+<button> "handle-button-press" !( event button -- ) [
+{ { [ over XButtonEvent-button Button1 = ] [ nip $action-1 call ] }
+ { [ over XButtonEvent-button Button2 = ] [ nip $action-2 call ] }
+ { [ over XButtonEvent-button Button3 = ] [ nip $action-3 call ] } }
+cond
+] add-method
\ No newline at end of file
--- /dev/null
+Eduardo Cavazos
--- /dev/null
+
+USING: kernel strings arrays sequences sequences.lib math x11.xlib
+ mortar mortar.sugar slot-accessors x x.pen x.widgets ;
+
+IN: x.widgets.keymenu
+
+SYMBOL: <keymenu>
+
+<keymenu> <widget> { "items" "pen" } accessors define-simple-class
+
+<keymenu> "create" !( <keymenu> -- keymenu )
+ [ new-empty <- keymenu-init ]
+add-class-method
+
+: numbers-and-letters ( -- seq )
+"1234567890abcdefghijklmnopqrstuvwxyz" [ 1string ] { } map-as ;
+
+<keymenu> {
+
+"keymenu-init" !( keymenu -- keymenu ) [
+ dup <pen> new* >>pen
+ ExposureMask KeyPressMask bitor >>mask
+ <- init-widget
+]
+
+"item-labels" !( keymenu -- labels ) [ $items [ first ] map ]
+
+"item-actions" !( keymenu -- actions ) [ $items [ second ] map ]
+
+"keymenu-labels" !( keymenu -- seq )
+[ numbers-and-letters swap <- item-labels [ " - " swap 3append ] 2map ]
+
+"reset-pen" !( keymenu -- keymenu ) [
+ dup $pen
+ 1 <-- set-x
+ dup $gc $font <- ascent 1+ <-- set-y
+ drop ]
+
+"handle-expose" !( event keymenu -- ) [
+ nip
+ <- reset-pen
+ dup $pen swap <- keymenu-labels
+ [ <-- draw-string dup $gc $font <- height <-- move-by-y ] each drop ]
+
+"keymenu-handle-key-press" !( event keymenu -- ) [
+ swap 0 key-event-to-string numbers-and-letters index
+ [ swap <- item-actions ?nth [ call ] when* ]
+ [ drop ]
+ if* ]
+
+"handle-key-press" !( event keymenu -- ) [ <- keymenu-handle-key-press ]
+
+"calc-height" !( keymenu -- height )
+ [ dup $items length swap $pen $gc $font <- height * ]
+
+"calc-width" !( keymenu -- width )
+ [ dup $pen $gc $font
+ swap $items [ first " " append ] map
+ dup empty? [ drop "" ] [ longest ] if
+ <-- text-width ]
+
+"calc-size" !( keymenu -- size )
+ [ dup <- calc-width swap <- calc-height 2array ]
+
+} add-methods
\ No newline at end of file
--- /dev/null
+Eduardo Cavazos
--- /dev/null
+
+USING: kernel x11.xlib mortar mortar.sugar slot-accessors x.gc x.widgets ;
+
+IN: x.widgets.label
+
+SYMBOL: <label>
+
+<label> <widget> { "gc" "text" } accessors define-simple-class
+
+<label> "create" !( text <label> -- label ) [
+new-empty swap >>text <gc> new* >>gc ExposureMask >>mask <- init-widget
+] add-class-method
+
+<label> "handle-expose" !( event label -- ) [
+ nip <- clear dup $gc { 20 20 } pick $text <---- draw-string
+] add-method
--- /dev/null
+
+USING: kernel io namespaces arrays sequences combinators math x11.xlib
+ mortar slot-accessors x ;
+
+IN: x.widgets
+
+SYMBOL: <widget>
+
+<widget> <window> { "mask" } accessors define-simple-class
+
+<widget> {
+
+"init-widget" !( widget -- widget )
+ [ <- init-window <- add-to-window-table dup $mask <-- select-input ]
+
+"add-to-window-table" !( window -- window )
+ [ dup $dpy over <-- add-to-window-table ]
+
+"remove-from-window-table" !( window -- window )
+ [ dup $dpy over <-- remove-from-window-table ]
+
+"handle-event" !( event widget -- ) [
+ over XAnyEvent-type
+ { { [ dup Expose = ] [ drop <- handle-expose ] }
+ { [ dup KeyPress = ] [ drop <- handle-key-press ] }
+ { [ dup ButtonPress = ] [ drop <- handle-button-press ] }
+ { [ dup EnterNotify = ] [ drop <- handle-enter-window ] }
+ { [ dup DestroyNotify = ] [ drop <- handle-destroy-window ] }
+ { [ dup MapRequest = ] [ drop <- handle-map-request ] }
+ { [ dup MapNotify = ] [ drop <- handle-map ] }
+ { [ dup ConfigureRequest = ] [ drop <- handle-configure-request ] }
+ { [ dup UnmapNotify = ] [ drop <- handle-unmap ] }
+ { [ dup PropertyNotify = ] [ drop <- handle-property ] }
+ { [ t ] [ "handle-event :: ignoring event"
+ print flush 3drop ] }
+ } cond ]
+
+} add-methods
\ No newline at end of file
--- /dev/null
+Eduardo Cavazos
--- /dev/null
+
+USING: kernel io namespaces arrays sequences
+ x11.xlib mortar slot-accessors x x.widgets ;
+
+IN: x.widgets.wm.child
+
+SYMBOL: <wm-child>
+
+<wm-child> <widget> { } define-simple-class
+
+<wm-child> "create" !( id <wm-child> -- wm-child ) [
+ new-empty swap >>id dpy get >>dpy PropertyChangeMask >>mask
+ <- add-to-save-set
+ 0 <-- set-border-width
+ <- add-to-window-table
+ dup $mask <-- select-input
+] add-class-method
+
+<wm-child> "handle-property" !( event wm-child -- ) [
+ drop
+ "child handle-property :: atom name = " write
+ XPropertyEvent-atom get-atom-name print flush
+] add-method
\ No newline at end of file
--- /dev/null
+Eduardo Cavazos
--- /dev/null
+Eduardo Cavazos
--- /dev/null
+
+USING: kernel namespaces arrays sequences combinators math.vectors
+ x11.xlib x11.constants
+ mortar slot-accessors x x.gc geom.rect ;
+
+IN: x.widgets.wm.frame.drag
+
+SYMBOL: <wm-frame-drag>
+
+<wm-frame-drag>
+ { "dpy" "gc" "frame" "event" "push" "posn" } accessors
+define-independent-class
+
+<wm-frame-drag> {
+
+"next-event" !( wfdm -- wfdm ) [ dup $dpy over $event <-- next-event 2drop ]
+
+"event-type" !( wfdm -- wfdm event-type ) [ dup $event XAnyEvent-type ]
+
+"drag-offset" !( wfdm -- offset ) [ dup $posn swap $push v- ]
+
+"update-posn" !( wfd -- wfd ) [ dup $event XMotionEvent-root-position >>posn ]
+
+} add-methods
--- /dev/null
+Eduardo Cavazos
--- /dev/null
+
+USING: kernel combinators namespaces math.vectors x11.xlib x11.constants
+ mortar mortar.sugar slot-accessors x x.gc x.widgets.wm.frame.drag ;
+
+IN: x.widgets.wm.frame.drag.move
+
+SYMBOL: <wm-frame-drag-move>
+
+<wm-frame-drag-move> <wm-frame-drag> { } define-simple-class
+
+<wm-frame-drag-move> "create" !( event frame <wm-frame-drag-move> -- ) [
+ new-empty swap >>frame swap >>event dup $frame $dpy >>dpy
+
+ <gc> new*
+ IncludeInferiors <-- set-subwindow-mode
+ GXxor <-- set-function
+ "white" <-- set-foreground
+ >>gc
+
+ dup $event XButtonEvent-root-position >>push
+ dup $event XButtonEvent-root-position >>posn
+ <- draw-move-outline
+ <- loop
+] add-class-method
+
+<wm-frame-drag-move> {
+
+"move-outline" !( wfdm -- rect )
+ [ dup $frame <- as-rect swap <- drag-offset <-- move-by ]
+
+"draw-move-outline" !( wfdm -- wfdm )
+ [ dpy get $default-root over $gc pick <- move-outline <--- draw-rect ]
+
+"loop" !( wfdm -- wfdm ) [
+ <- next-event
+ { { [ <- event-type MotionNotify = ]
+ [ <- draw-move-outline <- update-posn <- draw-move-outline <- loop ] }
+ { [ <- event-type ButtonRelease = ]
+ [ <- draw-move-outline
+ dup $frame <- position over <- drag-offset v+ >r
+ dup $frame r> <-- move drop
+ dup $frame <- raise drop drop ] }
+ { [ t ] [ <- loop ] } }
+ cond ]
+
+} add-methods
--- /dev/null
+Eduardo Cavazos
--- /dev/null
+
+USING: kernel combinators namespaces math.vectors x11.xlib x11.constants
+ mortar mortar.sugar slot-accessors geom.rect x x.gc x.widgets.wm.frame.drag ;
+
+IN: x.widgets.wm.frame.drag.size
+
+SYMBOL: <wm-frame-drag-size>
+
+<wm-frame-drag-size> <wm-frame-drag> { } define-simple-class
+
+<wm-frame-drag-size> "create" !( event frame <wfds> -- ) [
+ new-empty swap >>frame swap >>event
+ dup $frame $dpy >>dpy
+
+ <gc> new*
+ IncludeInferiors <-- set-subwindow-mode
+ GXxor <-- set-function
+ "white" <-- set-foreground
+ >>gc
+
+ dup $event XButtonEvent-root-position >>push
+ dup $event XButtonEvent-root-position >>posn
+ <- draw-size-outline <- loop
+] add-class-method
+
+<wm-frame-drag-size> {
+
+"size-outline" !( wfds -- rect )
+ [ dup $frame <- position swap $posn over v- <rect> new ]
+
+"draw-size-outline" !( wfdm -- wfdm )
+ [ dup $dpy $default-root over $gc pick <- size-outline <--- draw-rect ]
+
+"loop" !( wfdm -- ) [
+ <- next-event
+ { { [ <- event-type MotionNotify = ]
+ [ <- draw-size-outline <- update-posn <- draw-size-outline <- loop ] }
+ { [ <- event-type ButtonRelease = ]
+ [ <- draw-size-outline
+ dup $frame over $posn pick $frame <- position v- <-- resize
+ <- adjust-child drop ] }
+ { [ t ] [ <- loop ] } }
+ cond ]
+
+} add-methods
\ No newline at end of file
--- /dev/null
+
+USING: kernel io combinators namespaces quotations arrays sequences
+ math math.vectors
+ x11.xlib x11.constants
+ mortar mortar.sugar slot-accessors
+ geom.rect
+ math.bitwise
+ x x.gc x.widgets
+ x.widgets.button
+ x.widgets.wm.child
+ x.widgets.wm.frame.drag.move
+ x.widgets.wm.frame.drag.size ;
+
+IN: x.widgets.wm.frame
+
+SYMBOL: <wm-frame>
+
+<wm-frame> <widget> { "child" "gc" "last-state" } accessors define-simple-class
+
+<wm-frame> "create" !( id <wm-frame> -- wm-frame ) [
+ new-empty
+ swap <wm-child> new* >>child
+ <gc> new* "white" <-- set-foreground >>gc
+
+ {
+ SubstructureRedirectMask
+ ExposureMask
+ ButtonPressMask
+ ButtonReleaseMask
+ ButtonMotionMask
+ EnterWindowMask
+ ! experimental masks
+ SubstructureNotifyMask
+ } flags
+ >>mask
+
+ <- init-widget
+ "cornflowerblue" <-- set-background
+ dup $child <- position <-- move
+ dup $child over <-- reparent drop
+ <- position-child
+ <- fit-to-child
+ <- make-frame-button
+
+ <- map-subwindows
+ <- map
+] add-class-method
+
+SYMBOL: WM_PROTOCOLS
+SYMBOL: WM_DELETE_WINDOW
+
+: init-atoms ( -- )
+"WM_PROTOCOLS" 0 intern-atom WM_PROTOCOLS set
+"WM_DELETE_WINDOW" 0 intern-atom WM_DELETE_WINDOW set ;
+
+<wm-frame> {
+
+"fit-to-child" !( wm-frame -- wm-frame )
+ [ dup $child <- size { 10 20 } v+ <-- resize ]
+
+"position-child" !( wm-frame -- wm-frame )
+ [ dup $child { 5 15 } <-- move drop ]
+
+"set-child-size" !( wm-frame size -- frame )
+ [ >r dup $child r> <-- resize drop <- fit-to-child ]
+
+"set-child-width" !( wm-frame width -- frame )
+ [ >r dup $child r> <- set-width drop <- fit-to-child ]
+
+"set-child-height" !( wm-frame height -- frame )
+ [ >r dup $child r> <- set-height drop <- fit-to-child ]
+
+"adjust-child" !( wm-frame -- wm-frame )
+ [ dup $child over <- size { 10 20 } v- <-- resize drop ]
+
+"update-title" !( wm-frame -- wm-frame )
+ [ <- clear
+ dup >r
+ ! dup $gc { 5 1 } pick $child <- fetch-name <--- draw-string/top-left
+ dup $gc { 5 11 } pick $child <- fetch-name <---- draw-string
+ r> ]
+
+"delete-child" !( wm-frame -- wm-frame ) [
+ dup $child WM_PROTOCOLS get WM_DELETE_WINDOW get <--- send-client-message
+ drop ]
+
+"drag-move" !( event wm-frame -- ) [ <wm-frame-drag-move> new* ]
+
+"drag-size" !( event wm-frame -- ) [ <wm-frame-drag-size> new* ]
+
+"make-frame-button" !( frame -- frame ) [
+<button> new*
+ over <-- reparent
+ "" >>text
+ over [ <- unmap drop ] curry >>action-1
+ over [ <- delete-child drop ] curry >>action-3
+ { 9 9 } <-- resize
+ NorthEastGravity <-- set-gravity
+ "white" <-- set-background
+ over <- width 9 - 5 - 3 2array <-- move
+ drop ]
+
+! !!!!!!!!!! Event handlers !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+"handle-enter-window" !( event wm-frame -- )
+ [ nip $child RevertToPointerRoot CurrentTime <--- set-input-focus drop ]
+
+"handle-expose" !( event wm-frame -- ) [ nip <- clear <- update-title drop ]
+
+"handle-button-press" !( event wm-frame -- ) [
+ over XButtonEvent-button
+ { { [ dup Button1 = ] [ drop <- drag-move ] }
+ { [ dup Button2 = ] [ drop <- drag-size ] }
+ { [ t ] [ 3drop ] } }
+ cond ]
+
+"handle-map" !( event wm-frame -- )
+ [ "<wm-frame> handle-map :: ignoring values" print flush 2drop ]
+
+"handle-unmap" !( event wm-frame -- ) [ nip <- unmap drop ]
+
+"handle-destroy-window" !( event wm-frame -- ) [
+ nip dup $child <- remove-from-window-table drop
+ <- remove-from-window-table <- destroy ]
+
+"handle-configure-request" !( event frame -- ) [
+ { { [ over dup CWX? swap CWY? and ]
+ [ over XConfigureRequestEvent-position <-- move ] }
+ { [ over CWX? ] [ over XConfigureRequestEvent-x <-- set-x ] }
+ { [ over CWY? ] [ over XConfigureRequestEvent-y <-- set-y ] }
+ { [ t ] [ "<wm-frame> handle-configure-request :: move not requested"
+ print flush ] } }
+ cond
+
+ { { [ over dup CWWidth? swap CWHeight? and ]
+ [ over XConfigureRequestEvent-size <-- set-child-size ] }
+ { [ over CWWidth? ]
+ [ over XConfigureRequestEvent-width <-- set-child-width ] }
+ { [ over CWHeight? ]
+ [ over XConfigureRequestEvent-height <-- set-child-height ] }
+ { [ t ]
+ [ "<wm-frame> handle-configure-request :: resize not requested"
+ print flush ] } }
+ cond
+ 2drop ]
+
+} add-methods
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: wm-frame-maximize ( wm-frame -- wm-frame )
+<- save-state
+{ 0 0 } <-- move
+dup $dpy $default-root <- size
+ <-- resize
+<- adjust-child
+<- raise ;
+
+: wm-frame-maximize-vertical ( wm-frame -- wm-frame )
+0 <-- set-y
+dup $dpy $default-root <- height
+ <-- set-height
+<- adjust-child ;
+
+<wm-frame> "save-state" !( wm-frame -- wm-frame ) [
+ dup <- position
+ over <- size
+ <rect> new
+ >>last-state
+] add-method
+
+<wm-frame> "restore-state" !( wm-frame -- wm-frame ) [
+ dup $last-state $pos <-- move
+ dup $last-state $dim <-- resize
+ <- adjust-child
+] add-method
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
--- /dev/null
+Eduardo Cavazos
--- /dev/null
+
+USING: kernel x11.constants mortar mortar.sugar slot-accessors x.widgets.keymenu ;
+
+IN: x.widgets.wm.menu
+
+SYMBOL: <wm-menu>
+
+<wm-menu> <keymenu> { } define-simple-class
+
+<wm-menu> "create" !( <wm-menu> -- wm-menu )
+ [ new-empty <- keymenu-init ]
+add-class-method
+
+<wm-menu> {
+
+"wm-menu-handle-key-press" !( event wm-menu -- )
+ [ <- unmap <- keymenu-handle-key-press ]
+
+"handle-key-press" !( event wm-menu -- ) [ <- wm-menu-handle-key-press ]
+
+"wm-menu-popup" !( wm-menu -- wm-menu )
+ [ <- map <- raise RevertToPointerRoot CurrentTime <--- set-input-focus ]
+
+"popup" !( wm-menu -- wm-menu ) [ <- wm-menu-popup ]
+
+} add-methods
\ No newline at end of file
--- /dev/null
+Eduardo Cavazos
--- /dev/null
+
+USING: kernel io combinators namespaces arrays assocs sequences math
+ x11.xlib
+ x11.constants
+ vars mortar slot-accessors
+ x x.keysym-table x.widgets x.widgets.wm.child x.widgets.wm.frame ;
+
+IN: x.widgets.wm.root
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+SYMBOL: <wm-root>
+
+<wm-root>
+ <widget>
+ { "keymap" } accessors
+define-simple-class
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+VAR: wm-root
+
+: create-wm-root ( -- )
+ <wm-root> new-empty
+ dpy> >>dpy
+ dpy> $default-root $id >>id
+ SubstructureRedirectMask >>mask
+ <- add-to-window-table
+ SubstructureRedirectMask <-- select-input
+ H{ } clone >>keymap
+ >wm-root ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: find-in-table ( window -- object )
+dup >r $id dpy get $window-table at r> or ;
+
+: circulate-focus ( -- )
+dpy get $default-root <- children
+[ find-in-table ] map [ <- mapped? ] filter dup length 1 >
+[ reverse dup first <- lower drop
+ second <- raise
+ dup <wm-frame> is? [ $child ] [ ] if
+ RevertToPointerRoot CurrentTime <--- set-input-focus drop ]
+[ drop ]
+if ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: managed? ( id -- ? )
+dpy get $window-table values [ <wm-child> is? ] filter [ $id ] map member? ;
+
+: event>keyname ( event -- keyname ) lookup-keysym keysym>name ;
+
+: event>state-and-name ( event -- array )
+dup XKeyEvent-state swap event>keyname 2array ;
+
+: resolve-key-event ( keymap event -- item ) event>state-and-name swap at ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+<wm-root> {
+
+"handle-map-request" !( event wm-root -- ) [
+ { { [ over XMapRequestEvent-window managed? ]
+ [ "<wm-root> handle-map-request :: window already managed" print flush
+ 2drop ] }
+ { [ t ] [ drop XMapRequestEvent-window <wm-frame> <<- create drop ] } }
+ cond ]
+
+"handle-unmap" !( event wm-root -- ) [ 2drop ]
+
+"handle-key-press" !( event wm-root -- )
+ [ $keymap swap resolve-key-event call ]
+
+"grab-key" !( wm-root modifiers keyname -- wm-root modifiers keyname ) [
+ 3dup name>keysym keysym-to-keycode spin
+ False GrabModeAsync GrabModeAsync grab-key ]
+
+"set-key-action" !( wm-root modifiers keyname action -- wm-root ) [
+ >r <--- grab-key r>
+ -rot 2array pick $keymap set-at ]
+
+"handle-configure-request" !( event wm-root -- ) [
+ $dpy over XConfigureRequestEvent-window <window> new ! event window
+ { { [ over dup CWX? swap CWY? and ]
+ [ over XConfigureRequestEvent-position <-- move ] }
+ { [ over CWX? ] [ over XConfigureRequestEvent-x <-- set-x ] }
+ { [ over CWY? ] [ over XConfigureRequestEvent-y <-- set-y ] }
+ { [ t ] [ "<wm-root> handle-configure-request :: move not requested"
+ print flush ] } }
+ cond
+
+ { { [ over dup CWWidth? swap CWHeight? and ]
+ [ over XConfigureRequestEvent-size <-- resize ] }
+ { [ over CWWidth? ] [ over XConfigureRequestEvent-width <-- set-width ] }
+ { [ over CWHeight? ] [ over XConfigureRequestEvent-height <-- set-height ] }
+ { [ t ] [ "<wm-root> handle-configure-request :: resize not requested"
+ print flush ] } }
+ cond
+ 2drop ]
+
+} add-methods
\ No newline at end of file
--- /dev/null
+Eduardo Cavazos
--- /dev/null
+
+USING: kernel namespaces quotations arrays assocs sequences
+ mortar slot-accessors x x.widgets.wm.menu x.widgets.wm.frame
+ vars ;
+
+IN: x.widgets.wm.unmapped-frames-menu
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+SYMBOL: <unmapped-frames-menu>
+
+<unmapped-frames-menu> <wm-menu> { } define-simple-class
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+VAR: unmapped-frames-menu
+
+: create-unmapped-frames-menu ( -- )
+<unmapped-frames-menu>
+ new-empty
+ <- keymenu-init
+ 1 <-- set-border-width
+>unmapped-frames-menu ;
+
+: unmapped-frames ( -- seq )
+dpy get $window-table values
+[ <wm-frame> is? ] filter [ <- mapped? not ] filter ;
+
+<unmapped-frames-menu> {
+
+"refresh" !( menu -- menu ) [
+ unmapped-frames dup
+ [ $child <- fetch-name ] map swap
+ [ [ <- map ] curry ] map
+ [ 2array ] 2map
+ >>items
+ dup <- calc-size <-- resize ]
+
+"popup" !( menu -- menu ) [ <- refresh <- wm-menu-popup ]
+
+} add-methods
\ No newline at end of file
--- /dev/null
+Eduardo Cavazos
--- /dev/null
+
+USING: kernel namespaces namespaces.lib math sequences vars mortar
+accessors slot-accessors x ;
+
+IN: x.widgets.wm.workspace
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TUPLE: workspace windows ;
+
+C: <workspace> workspace
+
+VAR: workspaces
+
+VAR: current-workspace
+
+: init-workspaces ( -- ) V{ } clone >workspaces ;
+
+: add-workspace ( -- ) { } clone <workspace> workspaces> push ;
+
+: mapped-windows ( -- seq )
+dpy get $default-root <- children [ <- mapped? ] filter ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: switch-to-workspace ( n -- )
+mapped-windows current-workspace> workspaces> nth (>>windows)
+mapped-windows [ <- unmap drop ] each
+dup workspaces> nth windows>> [ <- map drop ] each
+current-workspace set* ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: next-workspace ( -- )
+current-workspace> 1+ dup workspaces> length <
+[ switch-to-workspace ] [ drop ] if ;
+
+: prev-workspace ( -- )
+current-workspace> 1- dup 0 >=
+[ switch-to-workspace ] [ drop ] if ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: setup-workspaces ( n -- )
+workspaces>
+ [ drop ]
+ [ init-workspaces [ add-workspace ] times 0 >current-workspace ]
+if ;
\ No newline at end of file
--- /dev/null
+
+USING: kernel io alien alien.c-types alien.strings namespaces threads
+ arrays sequences assocs math vars combinators.lib
+ x11.constants x11.events x11.xlib mortar slot-accessors geom.rect
+ io.encodings.ascii ;
+
+IN: x
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+SYMBOL: <display>
+
+SYMBOL: <window>
+
+! SYMBOL: dpy
+
+VAR: dpy
+
+<display>
+ { "ptr"
+ "name"
+ "default-screen"
+ "default-root"
+ "default-gc"
+ "black-pixel"
+ "white-pixel"
+ "colormap"
+ "window-table" } accessors
+define-independent-class
+
+<display> "create" !( name <display> -- display ) [
+ new-empty swap >>name
+ dup $name dup [ ascii string>alien ] [ ] if XOpenDisplay
+ dup [ >>ptr ] [ "XOpenDisplay error" throw ] if
+ dup $ptr XDefaultScreen >>default-screen
+ dup $ptr XDefaultRootWindow dupd <window> new >>default-root
+ dup $ptr over $default-screen XDefaultGC >>default-gc
+ dup $ptr over $default-screen XBlackPixel >>black-pixel
+ dup $ptr over $default-screen XWhitePixel >>white-pixel
+ dup $ptr over $default-screen XDefaultColormap >>colormap
+ H{ } clone >>window-table
+ [ <- start-event-loop ] in-thread
+] add-class-method
+
+{ "id" } accessors drop
+
+DEFER: check-window-table
+
+<display> {
+
+"add-to-window-table" !( display window -- )
+ [ dup $id rot $window-table set-at ]
+
+"remove-from-window-table" !( display window -- )
+ [ $id swap $window-table delete-at ]
+
+"next-event" !( display event -- display event )
+ [ over $ptr over XNextEvent drop ]
+
+"events-queued" !( display mode -- n ) [ >r $ptr r> XEventsQueued ]
+
+"concurrent-next-event" !( display event -- display event )
+ [ over QueuedAfterFlush <-- events-queued 0 >
+ [ <-- next-event ] [ 100 sleep <-- concurrent-next-event ] if ]
+
+"event-loop" !( display event -- )
+[ <-- concurrent-next-event
+ 2dup >r >r
+ dup XAnyEvent-window rot $window-table at dup
+ [ <- handle-event ] [ 2drop ] if
+ r> r>
+ <-- event-loop ]
+
+"start-event-loop" !( display -- ) [ "XEvent" <c-object> <-- event-loop ]
+
+"flush" !( display -- display ) [ dup $ptr XFlush drop ]
+
+"pointer-window" !( display -- window ) [
+ dup $ptr
+ over $default-root $id
+ 0 <Window>
+ 0 <Window> dup >r
+ 0 <int>
+ 0 <int>
+ 0 <int>
+ 0 <int>
+ 0 <uint>
+ XQueryPointer drop
+ r> *Window <window> new
+ check-window-table ]
+
+} add-methods
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+<window> { "dpy" "id" } accessors define-independent-class
+
+: create-window ( -- window ) <window> new-empty <- init-window ;
+
+: create-window-from-id ( dpy id -- window ) <window> new ;
+
+: check-window-table ( window -- window )
+ dup $id
+ over $dpy $window-table
+ at
+ swap or ;
+
+<window> "init-window"
+ !( window -- window )
+ [ dpy get
+ >>dpy
+ dpy get $ptr
+ dpy get $default-root $id
+ 0 0 100 100 0
+ dpy get $black-pixel
+ dpy get $white-pixel
+ XCreateSimpleWindow
+ >>id ]
+add-method
+
+! <window> new-empty <- init
+
+<window> "raw"
+ !( window -- dpy-ptr id )
+ [ dup $dpy $ptr swap $id ]
+add-method
+
+<window> "move"
+ !( window point -- window )
+ [ >r dup <- raw r> first2 XMoveWindow drop ]
+add-method
+
+<window> "set-x" !( window x -- window ) [
+ over <- y 2array <-- move
+] add-method
+
+<window> "set-y" !( window y -- window ) [
+ over <- x swap 2array <-- move
+] add-method
+
+<window> "flush"
+ !( window -- window )
+ [ dup $dpy <- flush drop ]
+add-method
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! 3 - Window Functions
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! 3.3 - Creating Windows
+
+<window> "destroy" !( window -- window )
+ [ dup <- raw XDestroyWindow drop ]
+add-method
+
+<window> "map"
+ !( window -- window )
+ [ dup <- raw XMapWindow drop ]
+add-method
+
+<window> "map-subwindows"
+ !( window -- window )
+ [ dup <- raw XMapSubwindows drop ]
+add-method
+
+<window> "unmap"
+ !( window -- window )
+ [ dup <- raw XUnmapWindow drop ]
+add-method
+
+<window> "unmap-subwindows"
+ !( window -- window )
+ [ dup <- raw XUnmapSubwindows drop ]
+add-method
+
+! 3.7 - Configuring Windows
+
+<window> "resize"
+ !( window size -- window )
+ [ >r dup <- raw r> first2 XResizeWindow drop ]
+add-method
+
+<window> "set-width"
+ !( window width -- window )
+ [ over <- height 2array <-- resize ]
+add-method
+
+<window> "set-height"
+ !( window height -- window )
+ [ over <- width swap 2array <-- resize ]
+add-method
+
+<window> "set-border-width"
+ !( window n -- window )
+ [ >r dup <- raw r> XSetWindowBorderWidth drop ]
+add-method
+
+! 3.8 Changing Window Stacking Order
+
+<window> "raise"
+ !( window -- window )
+ [ dup <- raw XRaiseWindow drop ]
+add-method
+
+<window> "lower"
+ !( window -- window )
+ [ dup <- raw XLowerWindow drop ]
+add-method
+
+! 3.9 - Changing Window Attributes
+
+! : change-window-attributes ( valuemask attr window -- )
+! -rot >r >r <- raw r> r> XChangeWindowAttributes drop ;
+
+<window> "change-attributes" !( window valuemask attr -- window ) [
+>r >r dup <- raw r> r> XChangeWindowAttributes drop
+] add-method
+
+DEFER: lookup-color
+
+<window> "set-background"
+ !( window color -- window )
+ [ >r dup <- raw r> lookup-color XSetWindowBackground drop ]
+add-method
+
+<window> "set-gravity" !( window gravity -- window ) [
+CWWinGravity swap
+"XSetWindowAttributes" <c-object> tuck set-XSetWindowAttributes-win_gravity
+<--- change-attributes
+] add-method
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! 4 - Window Information Functions
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! 4.1 - Obtaining Window Information
+
+<window> {
+
+"children" !( window -- seq )
+ [ <- raw 0 <uint> 0 <uint> f <void*> 0 <uint> 2dup >r >r XQueryTree drop
+ r> r> swap *void* swap *uint c-uint-array>
+ [ dpy get swap <window> new ] map ]
+
+"parent" !( window -- parent ) [
+ dup $dpy >r
+
+ dup $dpy $ptr
+ swap $id
+ 0 <Window>
+ 0 <Window> dup >r
+ f <void*>
+ 0 <uint>
+ XQueryTree drop
+ r> *Window
+ r> swap
+ <window> new
+ check-window-table ]
+
+"size" !( window -- size )
+ [ <- raw 0 <Window> 0 <int> 0 <int>
+ 0 <uint> 0 <uint> 2dup 2array >r
+ 0 <uint> 0 <uint>
+ XGetGeometry drop r> [ *uint ] map ]
+
+"width" !( window -- width ) [ <- size first ]
+
+"height" !( window -- height ) [ <- size second ]
+
+"position" !( window -- position )
+ [ <- raw 0 <Window>
+ 0 <uint> 0 <uint> 2dup 2array >r
+ 0 <uint> 0 <uint> 0 <uint> 0 <uint>
+ XGetGeometry drop r> [ *int ] map ]
+
+"x" !( window -- x ) [ <- position first ]
+
+"y" !( window -- y ) [ <- position second ]
+
+"as-rect" !( window -- rect ) [ dup <- position swap <- size <rect> new ]
+
+"attributes" !( window -- XWindowAttributes )
+ [ <- raw "XWindowAttributes" <c-object> dup >r XGetWindowAttributes drop r> ]
+
+"map-state" !( window -- state ) [ <- attributes XWindowAttributes-map_state ]
+
+"mapped?" !( window -- ? ) [ <- map-state IsUnmapped = not ]
+
+} add-methods
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: get-atom-name ( atom -- name ) dpy get $ptr swap XGetAtomName ;
+
+: intern-atom ( atom-name only-if-exists? -- atom )
+dpy get $ptr -rot XInternAtom ;
+
+: lookup-color ( name -- pixel )
+dpy get $ptr dpy get $colormap rot
+"XColor" <c-object> dup >r "XColor" <c-object> XLookupColor drop
+dpy get $ptr dpy get $colormap r> dup >r XAllocColor drop r> XColor-pixel ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! 8 - Graphics Functions
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+<window> "clear"
+ !( window -- window )
+ [ dup <- raw XClearWindow drop ]
+add-method
+
+<window> "draw-string"
+ !( window gc pos string -- )
+ [ >r >r >r <- raw r> $ptr r> [ >fixnum ] map first2 r> dup length
+ XDrawString drop ]
+add-method
+
+! <window> "draw-string"
+! !( window gc pos string -- )
+! [ >r >r >r <- raw r> $ptr r> [ >fixnum ] map first2 r> dup length
+! XDrawString drop ]
+! add-method
+
+<window> "draw-line"
+ !( window gc a b -- )
+ [ >r >r >r <- raw r> $ptr r> first2 r> first2 XDrawLine drop ]
+add-method
+
+<window> "draw-rect"
+ !( window gc rect -- )
+ [ 3dup dup <- top-left swap <- top-right <---- draw-line
+ 3dup dup <- top-right swap <- bottom-right <---- draw-line
+ 3dup dup <- bottom-left swap <- bottom-right <---- draw-line
+ dup <- top-left swap <- bottom-left <---- draw-line ]
+add-method
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! 9 - Window and Session Manager Functions
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+<window> "reparent"
+ !( window parent -- window )
+ [ >r dup <- raw r> $id 0 0 XReparentWindow drop ]
+add-method
+
+<window> "add-to-save-set" !( window -- window ) [
+ dup <- raw XAddToSaveSet drop
+] add-method
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! 10 - Events
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: XButtonEvent-root-position ( event -- position )
+dup XButtonEvent-x_root swap XButtonEvent-y_root 2array ;
+
+: XMotionEvent-root-position ( event -- position )
+dup XMotionEvent-x_root swap XMotionEvent-y_root 2array ;
+
+! Utility words for XConfigureRequestEvent
+
+: XConfigureRequestEvent-position ( XConfigureRequestEvent -- position )
+dup XConfigureRequestEvent-x swap XConfigureRequestEvent-y 2array ;
+
+: XConfigureRequestEvent-size ( XConfigureRequestEvent -- size )
+dup XConfigureRequestEvent-width swap XConfigureRequestEvent-height 2array ;
+
+: bit-test ( a b -- t-or-f ) bitand 0 = not ;
+
+: CWX? ( XConfigureRequestEvent -- bool )
+XConfigureRequestEvent-value_mask CWX bit-test ;
+
+: CWY? ( XConfigureRequestEvent -- bool )
+XConfigureRequestEvent-value_mask CWY bit-test ;
+
+: CWWidth? ( XConfigureRequestEvent -- bool )
+XConfigureRequestEvent-value_mask CWWidth bit-test ;
+
+: CWHeight? ( XConfigureRequestEvent -- bool )
+XConfigureRequestEvent-value_mask CWHeight bit-test ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! 11 - Event Handling Functions
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+<window> "select-input"
+ !( window mask -- window )
+ [ >r dup <- raw r> XSelectInput drop ]
+add-method
+
+! 11.8 - Handling Protocol Errors
+
+SYMBOL: error-handler-quot
+
+: error-handler-callback ( -- xt )
+"void" { "Display*" "XErrorEvent*" } "cdecl"
+[ error-handler-quot get call ] alien-callback ;
+
+: set-error-handler ( quot -- )
+error-handler-quot set error-handler-callback XSetErrorHandler drop ;
+
+: install-default-error-handler ( -- )
+[ "X11 : error-handler called" print flush ] set-error-handler ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! 12 - Input Device Functions
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! 12.2 - Keyboard Grabbing
+
+: grab-key
+( keycode modifiers grab-window owner-events pointer-mode keyboard-mode -- )
+>r >r >r <- raw >r -rot r> r> r> r> XGrabKey drop ;
+
+! 12.5 - Controlling Input Focus
+
+<window> "set-input-focus" !( window revert-to time -- window )
+ [ >r >r dup <- raw r> r> XSetInputFocus drop ]
+add-method
+
+: get-input-focus ( -- window )
+ dpy> $ptr
+ 0 <Window> dup >r
+ 0 <int>
+ XGetInputFocus drop
+ r> *Window
+ dpy> swap
+ create-window-from-id
+ check-window-table ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! 14 - Inter-Client Communication Functions
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+<window> "fetch-name" !( window -- name-or-f )
+ [ <- raw f <void*> dup >r XFetchName drop r>
+ dup *void* [ drop f ] [ *void* ascii alien>string ] if ]
+add-method
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! 16 - Application Utility Functions
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! 16.1 - Using Keyboard Utility Functions
+
+! this should go in xlib.factor
+
+USING: alien.syntax ;
+
+FUNCTION: KeyCode XKeysymToKeycode ( Display* display, KeySym keysym ) ;
+
+FUNCTION: KeySym XKeycodeToKeysym ( Display* display,
+ KeyCode keycode,
+ int index ) ;
+
+FUNCTION: char* XKeysymToString ( KeySym keysym ) ;
+
+: keysym-to-keycode ( keysym -- keycode ) dpy get $ptr swap XKeysymToKeycode ;
+
+USE: strings
+
+: lookup-string* ( event -- keysym string )
+10 "char" <c-array> dup >r 10 0 <KeySym> dup >r f XLookupString
+r> *KeySym swap r> swap c-char-array> >string ;
+
+: lookup-string ( event -- string ) lookup-string* nip ;
+
+: lookup-keysym ( event -- keysym ) lookup-string* drop ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!7
+
+: event-to-keysym ( event index -- keysym )
+>r dup XKeyEvent-display swap XKeyEvent-keycode r> XKeycodeToKeysym ;
+
+: keysym-to-string ( keysym -- string ) XKeysymToString ;
+
+: key-event-to-string ( event index -- str ) event-to-keysym keysym-to-string ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! Misc
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: no-modifiers ( -- mask ) 0 ;
+
+: control-alt ( -- mask ) ControlMask Mod1Mask bitor ;
+
+: alt ( -- mask ) Mod1Mask ;
+
+: True 1 ;
+: False 0 ;
+
+<window> "send-client-message" !( window message-type data -- window ) [
+
+"XClientMessageEvent" <c-object>
+
+tuck set-XClientMessageEvent-data0
+tuck set-XClientMessageEvent-message_type
+over $id over set-XClientMessageEvent-window
+ClientMessage over set-XClientMessageEvent-type
+32 over set-XClientMessageEvent-format
+CurrentTime over set-XClientMessageEvent-data1
+
+>r dup <- raw False NoEventMask r> XSendEvent drop
+
+] add-method
\ No newline at end of file
PLAF_DLL_OBJS += vm/cpu-x86.64.o
+CFLAGS += -DFACTOR_64
break;
}
- fprintf(stderr,"%lx %lx %s\n",(CELL)scan,scan->size,status);
+ print_cell_hex((CELL)scan); print_string(" ");
+ print_cell_hex(scan->size); print_string(" ");
+ print_string(status); print_string("\n");
scan = next_block(heap,scan);
}
- printf("%ld bytes of relocation data\n",size);
+ print_cell(size); print_string(" bytes of relocation data\n");
}
/* Compute where each block is going to go, after compaction */
/* Free all unreachable code blocks */
gc();
- fprintf(stderr,"*** Code heap compaction...\n");
- fflush(stderr);
-
/* Figure out where the code heap blocks are going to end up */
CELL size = compute_heap_forwarding(&code_heap);
CELL used, total_free, max_free;
heap_usage(&code_heap,&used,&total_free,&max_free);
- fprintf(stderr,"Code heap stats:\n");
- fprintf(stderr,"Used: %ld\n",used);
- fprintf(stderr,"Total free space: %ld\n",total_free);
- fprintf(stderr,"Largest free block: %ld\n",max_free);
+ print_string("Code heap stats:\n");
+ print_string("Used: "); print_cell(used); nl();
+ print_string("Total free space: "); print_cell(total_free); nl();
+ print_string("Largest free block: "); print_cell(max_free); nl();
fatal_error("Out of memory in add-compiled-block",0);
}
}
#include "master.h"
-#define ALLOC_DATA_HEAP "alloc_data_heap: gens=%ld, young_size=%ld, aging_size=%ld, tenured_size=%ld\n"
-#define GC_REQUESTED "garbage_collection: growing_data_heap=%d, requested_bytes=%ld\n"
-#define BEGIN_GC "begin_gc: growing_data_heap=%d, collecting_gen=%ld\n"
-#define END_GC "end_gc: gc_elapsed=%ld\n"
-#define END_AGING_GC "end_gc: aging_collections=%ld, cards_scanned=%ld\n"
-#define END_NURSERY_GC "end_gc: nursery_collections=%ld, cards_scanned=%ld\n"
-
-/* #define GC_DEBUG */
-
-#ifdef GC_DEBUG
- #define GC_PRINT printf
-#else
- INLINE void GC_PRINT() { }
-#endif
-
CELL init_zone(F_ZONE *z, CELL size, CELL start)
{
z->size = size;
CELL aging_size,
CELL tenured_size)
{
- GC_PRINT(ALLOC_DATA_HEAP,gens,young_size,aging_size,tenured_size);
-
young_size = align(young_size,DECK_SIZE);
aging_size = align(aging_size,DECK_SIZE);
tenured_size = align(tenured_size,DECK_SIZE);
old->new references */
void collect_cards(void)
{
- GC_PRINT("Collect cards\n");
-
int i;
for(i = collecting_gen + 1; i < data_heap->gen_count; i++)
collect_gen_cards(i);
CELL top = (CELL)stacks->callstack_top;
CELL bottom = (CELL)stacks->callstack_bottom;
- GC_PRINT("Collect callstack %ld %ld\n",top,bottom);
iterate_callstack(top,bottom,collect_stack_frame);
- GC_PRINT("Done\n");
}
}
the user environment and extra roots registered with REGISTER_ROOT */
void collect_roots(void)
{
- GC_PRINT("Collect roots\n");
copy_handle(&T);
copy_handle(&bignum_zero);
copy_handle(&bignum_pos_one);
so we set the newspace so the next generation. */
newspace = &data_heap->generations[collecting_gen + 1];
}
-
-#ifdef GC_DEBUG
- printf("\n");
- dump_generations();
- printf("Newspace: ");
- dump_zone(newspace);
- printf("\n");
-#endif
}
void end_gc(CELL gc_elapsed)
return;
}
- GC_PRINT(GC_REQUESTED,growing_data_heap_,requested_bytes);
-
s64 start = current_millis();
performing_gc = true;
}
}
- GC_PRINT(BEGIN_GC,growing_data_heap,collecting_gen);
begin_gc(requested_bytes);
/* initialize chase pointer */
CELL gc_elapsed = (current_millis() - start);
- GC_PRINT(END_GC,gc_elapsed);
end_gc(gc_elapsed);
performing_gc = false;
if(type_of(word->vocabulary) == STRING_TYPE)
{
print_chars(untag_string(word->vocabulary));
- printf(":");
+ print_string(":");
}
if(type_of(word->name) == STRING_TYPE)
print_chars(untag_string(word->name));
else
{
- printf("#<not a string: ");
+ print_string("#<not a string: ");
print_nested_obj(word->name,nesting);
- printf(">");
+ print_string(">");
}
}
-void print_string(F_STRING* str)
+void print_factor_string(F_STRING* str)
{
putchar('"');
print_chars(str);
for(i = 0; i < length; i++)
{
- printf(" ");
+ print_string(" ");
print_nested_obj(array_nth(array,i),nesting);
}
if(trimmed)
- printf("...");
+ print_string("...");
}
void print_tuple(F_TUPLE* tuple, CELL nesting)
F_TUPLE_LAYOUT *layout = untag_object(tuple->layout);
CELL length = to_fixnum(layout->size);
- printf(" ");
+ print_string(" ");
print_nested_obj(layout->class,nesting);
CELL i;
for(i = 0; i < length; i++)
{
- printf(" ");
+ print_string(" ");
print_nested_obj(tuple_nth(tuple,i),nesting);
}
if(trimmed)
- printf("...");
+ print_string("...");
}
void print_nested_obj(CELL obj, F_FIXNUM nesting)
{
if(nesting <= 0 && !full_output)
{
- printf(" ... ");
+ print_string(" ... ");
return;
}
switch(type_of(obj))
{
case FIXNUM_TYPE:
- printf("%ld",untag_fixnum_fast(obj));
+ print_fixnum(untag_fixnum_fast(obj));
break;
case WORD_TYPE:
print_word(untag_word(obj),nesting - 1);
break;
case STRING_TYPE:
- print_string(untag_string(obj));
+ print_factor_string(untag_string(obj));
break;
case F_TYPE:
- printf("f");
+ print_string("f");
break;
case TUPLE_TYPE:
- printf("T{");
+ print_string("T{");
print_tuple(untag_object(obj),nesting - 1);
- printf(" }");
+ print_string(" }");
break;
case ARRAY_TYPE:
- printf("{");
+ print_string("{");
print_array(untag_object(obj),nesting - 1);
- printf(" }");
+ print_string(" }");
break;
case QUOTATION_TYPE:
- printf("[");
+ print_string("[");
quot = untag_object(obj);
print_array(untag_object(quot->array),nesting - 1);
- printf(" ]");
+ print_string(" ]");
break;
default:
- printf("#<type %ld @ %lx>",type_of(obj),obj);
+ print_string("#<type "); print_cell(type_of(obj)); print_string(" @ "); print_cell_hex(obj);
break;
}
}
for(; start <= end; start += CELLS)
{
print_obj(get(start));
- printf("\n");
+ nl();
}
}
void print_datastack(void)
{
- printf("==== DATA STACK:\n");
+ print_string("==== DATA STACK:\n");
print_objects(ds_bot,ds);
}
void print_retainstack(void)
{
- printf("==== RETAIN STACK:\n");
+ print_string("==== RETAIN STACK:\n");
print_objects(rs_bot,rs);
}
void print_stack_frame(F_STACK_FRAME *frame)
{
print_obj(frame_executing(frame));
- printf("\n");
+ print_string("\n");
print_obj(frame_scan(frame));
- printf("\n");
- printf("%lx\n",(CELL)frame_executing(frame));
- printf("%lx\n",(CELL)frame->xt);
+ print_string("\n");
+ print_cell_hex((CELL)frame_executing(frame));
+ print_cell_hex((CELL)frame->xt);
}
void print_callstack(void)
{
- printf("==== CALL STACK:\n");
+ print_string("==== CALL STACK:\n");
CELL bottom = (CELL)stack_chain->callstack_bottom;
CELL top = (CELL)stack_chain->callstack_top;
iterate_callstack(top,bottom,print_stack_frame);
void dump_cell(CELL cell)
{
- printf("%08lx: ",cell);
+ print_cell_hex_pad(cell); print_string(": ");
cell = get(cell);
- printf("%08lx tag %ld",cell,TAG(cell));
+ print_cell_hex_pad(cell); print_string(" tag "); print_cell(TAG(cell));
switch(TAG(cell))
{
case BIGNUM_TYPE:
case FLOAT_TYPE:
if(cell == F)
- printf(" -- F");
+ print_string(" -- F");
else if(cell < TYPE_COUNT<<TAG_BITS)
- printf(" -- possible header: %ld",cell>>TAG_BITS);
+ {
+ print_string(" -- possible header: ");
+ print_cell(cell>>TAG_BITS);
+ }
else if(cell >= data_heap->segment->start
&& cell < data_heap->segment->end)
{
CELL header = get(UNTAG(cell));
CELL type = header>>TAG_BITS;
- printf(" -- object; ");
+ print_string(" -- object; ");
if(TAG(header) == 0 && type < TYPE_COUNT)
- printf(" type %ld",type);
+ {
+ print_string(" type "); print_cell(type);
+ }
else
- printf(" header corrupt");
+ print_string(" header corrupt");
}
break;
}
- printf("\n");
+ nl();
}
void dump_memory(CELL from, CELL to)
void dump_zone(F_ZONE *z)
{
- printf("start=%ld, size=%ld, here=%ld\n",
- z->start,z->size,z->here - z->start);
+ print_string("Start="); print_cell(z->start);
+ print_string(", size="); print_cell(z->size);
+ print_string(", here="); print_cell(z->here - z->start); nl();
}
void dump_generations(void)
{
- int i;
+ CELL i;
- printf("Nursery: ");
+ print_string("Nursery: ");
dump_zone(&nursery);
for(i = 1; i < data_heap->gen_count; i++)
{
- printf("Generation %d: ",i);
+ print_string("Generation "); print_cell(i); print_string(": ");
dump_zone(&data_heap->generations[i]);
}
for(i = 0; i < data_heap->gen_count; i++)
{
- printf("Semispace %d: ",i);
+ print_string("Semispace "); print_cell(i); print_string(": ");
dump_zone(&data_heap->semispaces[i]);
}
- printf("Cards: base=%lx, size=%lx\n",
- (CELL)data_heap->cards,
- (CELL)(data_heap->cards_end - data_heap->cards));
+ print_string("Cards: base=");
+ print_cell((CELL)data_heap->cards);
+ print_string(", size=");
+ print_cell((CELL)(data_heap->cards_end - data_heap->cards));
+ nl();
}
void dump_objects(F_FIXNUM type)
{
if(type == -1 || type_of(obj) == type)
{
- printf("%lx ",obj);
+ print_cell_hex_pad(obj);
+ print_string(" ");
print_nested_obj(obj,2);
- printf("\n");
+ nl();
}
}
{
if(look_for == *scan)
{
- printf("%lx ",obj);
+ print_cell_hex_pad(obj);
+ print_string(" ");
print_nested_obj(obj,2);
- printf("\n");
+ nl();
}
}
if(look_for == get(scan))
{
- printf("%lx ",obj);
+ print_cell_hex_pad(obj);
+ print_string(" ");
print_nested_obj(obj,2);
- printf("\n");
+ nl();
}
}
}
{
if(fep_disabled)
{
- printf("Low level debugger disabled\n");
+ print_string("Low level debugger disabled\n");
exit(1);
}
- open_console();
-
- printf("Starting low level debugger...\n");
- printf(" Basic commands:\n");
- printf("q -- continue executing Factor - NOT SAFE\n");
- printf("im -- save image to fep.image\n");
- printf("x -- exit Factor\n");
- printf(" Advanced commands:\n");
- print
f("d <addr> <count> -- dump memory\n");
- print
f("u <addr> -- dump object at tagged <addr>\n");
- print
f(". <addr> -- print object at tagged <addr>\n");
- printf("t -- toggle output trimming\n");
- printf("s r -- dump data, retain stacks\n");
- printf(".s .r .c -- print data, retain, call stacks\n");
- printf("e -- dump environment\n");
- printf("g -- dump generations\n");
- print
f("card <addr> -- print card containing address\n");
- printf("addr <card> -- print address containing card\n");
- printf("data -- data heap dump\n");
- printf("words -- words dump\n");
- printf("tuples -- tuples dump\n");
- print
f("refs <addr> -- find data heap references to object\n");
- print
f("push <addr> -- push object on data stack - NOT SAFE\n");
- printf("code -- code heap dump\n");
+ /* open_console(); */
+
+ print_string("Starting low level debugger...\n");
+ print_string(" Basic commands:\n");
+ print_string("q -- continue executing Factor - NOT SAFE\n");
+ print_string("im -- save image to fep.image\n");
+ print_string("x -- exit Factor\n");
+ print_string(" Advanced commands:\n");
+ print
_string("d <addr> <count> -- dump memory\n");
+ print
_string("u <addr> -- dump object at tagged <addr>\n");
+ print
_string(". <addr> -- print object at tagged <addr>\n");
+ print_string("t -- toggle output trimming\n");
+ print_string("s r -- dump data, retain stacks\n");
+ print_string(".s .r .c -- print data, retain, call stacks\n");
+ print_string("e -- dump environment\n");
+ print_string("g -- dump generations\n");
+ print
_string("card <addr> -- print card containing address\n");
+ print_string("addr <card> -- print address containing card\n");
+ print_string("data -- data heap dump\n");
+ print_string("words -- words dump\n");
+ print_string("tuples -- tuples dump\n");
+ print
_string("refs <addr> -- find data heap references to object\n");
+ print
_string("push <addr> -- push object on data stack - NOT SAFE\n");
+ print_string("code -- code heap dump\n");
bool seen_command = false;
{
char cmd[1024];
- printf("READY\n");
+ print_string("READY\n");
fflush(stdout);
if(scanf("%1000s",cmd) <= 0)
if(strcmp(cmd,"d") == 0)
{
- CELL addr, count;
- scanf("%lx %lx",&addr,&count);
+ CELL addr = read_cell_hex();
+ scanf(" ");
+ CELL count = read_cell_hex();
dump_memory(addr,addr+count);
}
- if(strcmp(cmd,"u") == 0)
+ else if(strcmp(cmd,"u") == 0)
{
- CELL addr, count;
- scanf("%lx",&addr);
- count = object_size(addr);
+ CELL addr = read_cell_hex();
+ CELL count = object_size(addr);
dump_memory(addr,addr+count);
}
else if(strcmp(cmd,".") == 0)
{
- CELL addr;
- scanf("%lx",&addr);
+ CELL addr = read_cell_hex();
print_obj(addr);
- printf("\n");
+ print_string("\n");
}
else if(strcmp(cmd,"t") == 0)
full_output = !full_output;
dump_generations();
else if(strcmp(cmd,"card") == 0)
{
- CELL addr;
- scanf("%lx",&addr);
- printf("%lx\n",(CELL)ADDR_TO_CARD(addr));
+ CELL addr = read_cell_hex();
+ print_cell_hex((CELL)ADDR_TO_CARD(addr));
+ nl();
}
else if(strcmp(cmd,"addr") == 0)
{
- CELL card;
- scanf("%lx",&card);
- printf("%lx\n",(CELL)CARD_TO_ADDR(card));
+ CELL card = read_cell_hex();
+ print_cell_hex((CELL)CARD_TO_ADDR(card));
+ nl();
}
else if(strcmp(cmd,"q") == 0)
return;
dump_objects(-1);
else if(strcmp(cmd,"refs") == 0)
{
- CELL addr;
- scanf("%lx",&addr);
- printf("Data heap references:\n");
+ CELL addr = read_cell_hex();
+ print_string("Data heap references:\n");
find_data_references(addr);
- printf("Code heap references:\n");
+ print_string("Code heap references:\n");
find_code_references(addr);
- printf("\n");
+ nl();
}
else if(strcmp(cmd,"words") == 0)
dump_objects(WORD_TYPE);
dump_objects(TUPLE_TYPE);
else if(strcmp(cmd,"push") == 0)
{
- CELL addr;
- scanf("%lx",&addr);
+ CELL addr = read_cell_hex();
dpush(addr);
}
else if(strcmp(cmd,"code") == 0)
dump_heap(&code_heap);
else
- printf("unknown command\n");
+ print_string("unknown command\n");
}
}
void primitive_die(void)
{
- fprintf(stderr,"The die word was called by the library. Unless you called it yourself,\n");
- fprintf(stderr,"you have triggered a bug in Factor. Please report.\n");
+ print_string("The die word was called by the library. Unless you called it yourself,\n");
+ print_string("you have triggered a bug in Factor. Please report.\n");
factorbug();
}
void out_of_memory(void)
{
- fprintf(stderr,"Out of memory\n\n");
+ print_string("Out of memory\n\n");
dump_generations();
exit(1);
}
void fatal_error(char* msg, CELL tagged)
{
- fprintf(stderr,"fatal_error: %s %lx\n",msg,tagged);
+ print_string("fatal_error: "); print_string(msg);
+ print_string(": "); print_cell_hex(tagged); nl();
exit(1);
}
void critical_error(char* msg, CELL tagged)
{
- fprintf(stderr,"You have triggered a bug in Factor. Please report.\n");
- fprintf(stderr,"critical_error: %s %lx\n",msg,tagged);
+ print_string("You have triggered a bug in Factor. Please report.\n");
+ print_string("critical_error: "); print_string(msg);
+ print_string(": "); print_cell_hex(tagged); nl();
factorbug();
}
crash. */
else
{
- printf("You have triggered a bug in Factor. Please report.\n");
- printf("early_error: ");
+ print_string("You have triggered a bug in Factor. Please report.\n");
+ print_string("early_error: ");
print_obj(error);
- printf("\n");
+ nl();
factorbug();
}
}
/* Do some initialization that we do once only */
void do_stage1_init(void)
{
- fprintf(stderr,"*** Stage 2 early init... ");
- fflush(stderr);
+ print_string("*** Stage 2 early init... ");
+ fflush(stdout);
CELL words = find_all_words();
userenv[STAGE2_ENV] = T;
- fprintf(stderr,"done\n");
- fflush(stderr);
+ print_string("done\n");
+ fflush(stdout);
}
/* Get things started */
void ffi_test_0(void)
{
- printf("ffi_test_0()\n");
}
int ffi_test_1(void)
{
- printf("ffi_test_1()\n");
return 3;
}
int ffi_test_2(int x, int y)
{
- printf("ffi_test_2(%d,%d)\n",x,y);
return x + y;
}
int ffi_test_3(int x, int y, int z, int t)
{
- printf("ffi_test_3(%d,%d,%d,%d)\n",x,y,z,t);
return x + y + z * t;
}
float ffi_test_4(void)
{
- printf("ffi_test_4()\n");
return 1.5;
}
double ffi_test_5(void)
{
- printf("ffi_test_5()\n");
return 1.5;
}
double ffi_test_6(float x, float y)
{
- printf("ffi_test_6(%f,%f)\n",x,y);
return x * y;
}
double ffi_test_7(double x, double y)
{
- printf("ffi_test_7(%f,%f)\n",x,y);
return x * y;
}
double ffi_test_8(double x, float y, double z, float t, int w)
{
- printf("ffi_test_8(%f,%f,%f,%f,%d)\n",x,y,z,t,w);
return x * y + z * t + w;
}
int ffi_test_9(int a, int b, int c, int d, int e, int f, int g)
{
- printf("ffi_test_9(%d,%d,%d,%d,%d,%d,%d)\n",a,b,c,d,e,f,g);
return a + b + c + d + e + f + g;
}
int ffi_test_10(int a, int b, double c, int d, float e, int f, int g, int h)
{
- printf("ffi_test_10(%d,%d,%f,%d,%f,%d,%d,%d)\n",a,b,c,d,e,f,g,h);
return a - b - c - d - e - f - g - h;
}
int ffi_test_11(int a, struct foo b, int c)
{
- printf("ffi_test_11(%d,{%d,%d},%d)\n",a,b.x,b.y,c);
return a * b.x + c * b.y;
}
int ffi_test_12(int a, int b, struct rect c, int d, int e, int f)
{
- printf("ffi_test_12(%d,%d,{%f,%f,%f,%f},%d,%d,%d)\n",a,b,c.x,c.y,c.w,c.h,d,e,f);
return a + b + c.x + c.y + c.w + c.h + d + e + f;
}
int ffi_test_13(int a, int b, int c, int d, int e, int f, int g, int h, int i, int j, int k)
{
- printf("ffi_test_13(%d,%d,%d,%d,%d,%d,%d,%d,%d,%d,%d)\n",a,b,c,d,e,f,g,h,i,j,k);
return a + b + c + d + e + f + g + h + i + j + k;
}
struct foo ffi_test_14(int x, int y)
{
struct foo r;
- printf("ffi_test_14(%d,%d)\n",x,y);
r.x = x; r.y = y;
return r;
}
F_STDCALL int ffi_test_18(int x, int y, int z, int t)
{
- printf("ffi_test_18(%d,%d,%d,%d)\n",x,y,z,t);
return x + y + z * t;
}
double y1, double y2, double y3,
double z1, double z2, double z3)
{
- printf("ffi_test_20(%f,%f,%f,%f,%f,%f,%f,%f,%f)\n",
- x1, x2, x3, y1, y2, y3, z1, z2, z3);
}
long long ffi_test_21(long x, long y)
long ffi_test_22(long x, long long y, long long z)
{
- printf("ffi_test_22(%ld,%lld,%lld)\n",x,y,z);
return x + y / z;
}
return s;
}
-void ffi_test_31(int x0, int x1, int x2, int x3, int x4, int x5, int x6, int x7, int x8, int x9, int x10, int x11, int x12, int x13, int x14, int x15, int x16, int x17, int x18, int x19, int x20, int x21, int x22, int x23, int x24, int x25, int x26, int x27, int x28, int x29, int x30, int x31, int x32, int x33, int x34, int x35, int x36, int x37, int x38, int x39, int x40, int x41) { }
+int ffi_test_31(int x0, int x1, int x2, int x3, int x4, int x5, int x6, int x7, int x8, int x9, int x10, int x11, int x12, int x13, int x14, int x15, int x16, int x17, int x18, int x19, int x20, int x21, int x22, int x23, int x24, int x25, int x26, int x27, int x28, int x29, int x30, int x31, int x32, int x33, int x34, int x35, int x36, int x37, int x38, int x39, int x40, int x41)
+{
+ return x0 + x1 + x2 + x3 + x4 + x5 + x6 + x7 + x8 + x9 + x10 + x11 + x12 + x13 + x14 + x15 + x16 + x17 + x18 + x19 + x20 + x21 + x22 + x23 + x24 + x25 + x26 + x27 + x28 + x29 + x30 + x31 + x32 + x33 + x34 + x35 + x36 + x37 + x38 + x39 + x40 + x41;
+}
+
+float ffi_test_31_point_5(float x0, float x1, float x2, float x3, float x4, float x5, float x6, float x7, float x8, float x9, float x10, float x11, float x12, float x13, float x14, float x15, float x16, float x17, float x18, float x19, float x20, float x21, float x22, float x23, float x24, float x25, float x26, float x27, float x28, float x29, float x30, float x31, float x32, float x33, float x34, float x35, float x36, float x37, float x38, float x39, float x40, float x41)
+{
+ return x0 + x1 + x2 + x3 + x4 + x5 + x6 + x7 + x8 + x9 + x10 + x11 + x12 + x13 + x14 + x15 + x16 + x17 + x18 + x19 + x20 + x21 + x22 + x23 + x24 + x25 + x26 + x27 + x28 + x29 + x30 + x31 + x32 + x33 + x34 + x35 + x36 + x37 + x38 + x39 + x40 + x41;
+}
double ffi_test_32(struct test_struct_8 x, int y)
{
void ffi_test_36_point_5(void)
{
- printf("ffi_test_36_point_5\n");
global_var = 0;
}
int ffi_test_37(int (*f)(int, int, int))
{
- printf("ffi_test_37\n");
- printf("global_var is %d\n",global_var);
global_var = f(global_var,global_var * 2,global_var * 3);
- printf("global_var is %d\n",global_var);
- fflush(stdout);
return global_var;
}
int ffi_test_39(long a, long b, struct test_struct_13 s)
{
- printf("ffi_test_39(%ld,%ld,%f,%f,%f,%f,%f,%f)\n",a,b,s.x1,s.x2,s.x3,s.x4,s.x5,s.x6);
if(a != b) abort();
return s.x1 + s.x2 + s.x3 + s.x4 + s.x5 + s.x6;
}
struct test_struct_14 retval;
retval.x1 = x1;
retval.x2 = x2;
- printf("ffi_test_40(%f,%f)\n",x1,x2);
return retval;
}
struct test_struct_12 retval;
retval.a = a;
retval.x = x;
- printf("ffi_test_41(%d,%f)\n",a,x);
return retval;
}
struct test_struct_15 retval;
retval.x = x;
retval.y = y;
- printf("ffi_test_42(%f,%f)\n",x,y);
return retval;
}
struct test_struct_16 retval;
retval.x = x;
retval.a = a;
- printf("ffi_test_43(%f,%d)\n",x,a);
return retval;
}
struct test_struct_14 retval;
retval.x1 = 1.0;
retval.x2 = 2.0;
- //printf("ffi_test_44()\n");
return retval;
}
DLLEXPORT struct test_struct_6 ffi_test_29(void);
struct test_struct_7 { char x, y, z, a, b, c, d; };
DLLEXPORT struct test_struct_7 ffi_test_30(void);
-DLLEXPORT void ffi_test_31(int x0, int x1, int x2, int x3, int x4, int x5, int x6, int x7, int x8, int x9, int x10, int x11, int x12, int x13, int x14, int x15, int x16, int x17, int x18, int x19, int x20, int x21, int x22, int x23, int x24, int x25, int x26, int x27, int x28, int x29, int x30, int x31, int x32, int x33, int x34, int x35, int x36, int x37, int x38, int x39, int x40, int x41);
+DLLEXPORT int ffi_test_31(int x0, int x1, int x2, int x3, int x4, int x5, int x6, int x7, int x8, int x9, int x10, int x11, int x12, int x13, int x14, int x15, int x16, int x17, int x18, int x19, int x20, int x21, int x22, int x23, int x24, int x25, int x26, int x27, int x28, int x29, int x30, int x31, int x32, int x33, int x34, int x35, int x36, int x37, int x38, int x39, int x40, int x41);
+DLLEXPORT float ffi_test_31_point_5(float x0, float x1, float x2, float x3, float x4, float x5, float x6, float x7, float x8, float x9, float x10, float x11, float x12, float x13, float x14, float x15, float x16, float x17, float x18, float x19, float x20, float x21, float x22, float x23, float x24, float x25, float x26, float x27, float x28, float x29, float x30, float x31, float x32, float x33, float x34, float x35, float x36, float x37, float x38, float x39, float x40, float x41);
struct test_struct_8 { double x; double y; };
DLLEXPORT double ffi_test_32(struct test_struct_8 x, int y);
struct test_struct_9 { float x; float y; };
F_ZONE *tenured = &data_heap->generations[TENURED];
- long int bytes_read = fread((void*)tenured->start,1,h->data_size,file);
+ F_FIXNUM bytes_read = fread((void*)tenured->start,1,h->data_size,file);
if(bytes_read != h->data_size)
{
- fprintf(stderr,"truncated image: %ld bytes read, %ld bytes expected\n",
- bytes_read,h->data_size);
+ print_string("truncated image: ");
+ print_fixnum(bytes_read);
+ print_string(" bytes read, ");
+ print_cell(h->data_size);
+ print_string(" bytes expected\n");
fatal_error("load_data_heap failed",0);
}
if(h->code_size != 0)
{
- long int bytes_read = fread(first_block(&code_heap),1,h->code_size,file);
+ F_FIXNUM bytes_read = fread(first_block(&code_heap),1,h->code_size,file);
if(bytes_read != h->code_size)
{
- fprintf(stderr,"truncated image: %ld bytes read, %ld bytes expected\n",
- bytes_read,h->code_size);
+ print_string("truncated image: ");
+ print_fixnum(bytes_read);
+ print_string(" bytes read, ");
+ print_cell(h->code_size);
+ print_string(" bytes expected\n");
fatal_error("load_code_heap failed",0);
}
}
FILE *file = OPEN_READ(p->image);
if(file == NULL)
{
- FPRINTF(stderr,"Cannot open image file: %s\n",p->image);
- fprintf(stderr,"%s\n",strerror(errno));
+ print_string("Cannot open image file: "); print_native_string(p->image); nl();
+ print_string(strerror(errno)); nl();
exit(1);
}
FILE* file;
F_HEADER h;
- FPRINTF(stderr,"*** Saving %s...\n",filename);
-
file = OPEN_WRITE(filename);
if(file == NULL)
{
- fprintf(stderr,"Cannot open image file: %s\n",strerror(errno));
+ print_string("Cannot open image file: "); print_native_string(filename); nl();
+ print_string(strerror(errno)); nl();
return false;
}
if(fwrite((void*)tenured->start,h.data_size,1,file) != 1)
{
- fprintf(stderr,"Save data heap failed: %s\n",strerror(errno));
+ print_string("Save data heap failed: "); print_string(strerror(errno)); nl();
return false;
}
if(fwrite(first_block(&code_heap),h.code_size,1,file) != 1)
{
- fprintf(stderr,"Save code heap failed: %s\n",strerror(errno));
+ print_string("Save code heap failed: "); print_string(strerror(errno)); nl();
return false;
}
if(fclose(file))
{
- fprintf(stderr,"Failed to close image file: %s\n",strerror(errno));
+ print_string("Failed to close image file: "); print_string(strerror(errno)); nl();
return false;
}
int nArgs;
szArglist = CommandLineToArgvW(GetCommandLineW(), &nArgs);
- if( NULL == szArglist )
+ if(NULL == szArglist)
{
- wprintf(L"CommandLineToArgvW failed\n");
+ print_string("CommandLineToArgvW failed\n");
return 1;
}
}
else if(y < WORD_SIZE - TAG_BITS)
{
- F_FIXNUM mask = -(1L << (WORD_SIZE - 1 - TAG_BITS - y));
+ F_FIXNUM mask = -((F_FIXNUM)1 << (WORD_SIZE - 1 - TAG_BITS - y));
if((x > 0 && (x & mask) == 0) || (x & mask) == mask)
{
dpush(tag_fixnum(x << y));
#define STRNCMP strncmp
#define STRDUP strdup
+#define CELL_FORMAT "%lu"
+#define CELL_HEX_FORMAT "%lx"
+
+#ifdef FACTOR_64
+ #define CELL_HEX_PAD_FORMAT "%016lx"
+#else
+ #define CELL_HEX_PAD_FORMAT "%08lx"
+#endif
+
+#define FIXNUM_FORMAT "%ld"
+
#define OPEN_READ(path) fopen(path,"rb")
#define OPEN_WRITE(path) fopen(path,"wb")
-#define FPRINTF(stream,format,arg) fprintf(stream,format,arg)
+
+#define print_native_string(string) print_string(string)
void start_thread(void *(*start_routine)(void *));
signal_number = ERROR_DIVIDE_BY_ZERO;
c->EIP = (CELL)divide_by_zero_signal_handler_impl;
}
- else
+ /* If the Widcomm bluetooth stack is installed, the BTTray.exe process
+ injects code into running programs. For some reason this results in
+ random SEH exceptions with this (undocumented) exception code being
+ raised. The workaround seems to be ignoring this altogether, since that
+ is what happens if SEH is not enabled. Don't really have any idea what
+ this exception means. */
+ else if(e->ExceptionCode != 0x40010006)
{
signal_number = 11;
c->EIP = (CELL)misc_signal_handler_impl;
BY_HANDLE_FILE_INFORMATION bhfi;
F_CHAR *path = unbox_u16_string();
- //wprintf(L"path = %s\n", path);
HANDLE h = CreateFileW(path,
GENERIC_READ,
FILE_SHARE_READ,
#define STRNCMP wcsncmp
#define STRDUP _wcsdup
+#define CELL_FORMAT "%Iu"
+#define CELL_HEX_FORMAT "%Ix"
+
+#ifdef FACTOR_64
+ #define CELL_HEX_PAD_FORMAT "%016Ix"
+#else
+ #define CELL_HEX_PAD_FORMAT "%08Ix"
+#endif
+
+#define FIXNUM_FORMAT "%Id"
+
#define OPEN_READ(path) _wfopen(path,L"rb")
#define OPEN_WRITE(path) _wfopen(path,L"wb")
-#define FPRINTF(stream,format,arg) fwprintf(stream,L##format,arg)
+#define print_native_string(string) wprintf(L"%s",arg)
/* Difference between Jan 1 00:00:00 1601 and Jan 1 00:00:00 1970 */
#define EPOCH_OFFSET 0x019db1ded53e8000LL
if(!ptr) fatal_error("Out of memory in safe_strdup", 0);
return ptr;
}
+
+/* We don't use printf directly, because format directives are not portable.
+Instead we define the common cases here. */
+void nl(void)
+{
+ fputs("\n",stdout);
+}
+
+void print_string(const char *str)
+{
+ fputs(str,stdout);
+}
+
+void print_cell(CELL x)
+{
+ printf(CELL_FORMAT,x);
+}
+
+void print_cell_hex(CELL x)
+{
+ printf(CELL_HEX_FORMAT,x);
+}
+
+void print_cell_hex_pad(CELL x)
+{
+ printf(CELL_HEX_PAD_FORMAT,x);
+}
+
+void print_fixnum(F_FIXNUM x)
+{
+ printf(CELL_FORMAT,x);
+}
+
+CELL read_cell_hex(void)
+{
+ CELL cell;
+ scanf(CELL_HEX_FORMAT,&cell);
+ return cell;
+};
void *safe_malloc(size_t size);
F_CHAR *safe_strdup(const F_CHAR *str);
+
+void nl(void);
+void print_string(const char *str);
+void print_cell(CELL x);
+void print_cell_hex(CELL x);
+void print_cell_hex_pad(CELL x);
+void print_fixnum(F_FIXNUM x);
+CELL read_cell_hex(void);
projects / factor.git / commitdiff
