Merge git://factorcode.org/git/factor
Doug Coleman
commit
75bc819db2
|
|
@ -79,7 +79,7 @@ M: int-regs inc-reg-class
|
|||
|
||||
M: float-regs inc-reg-class
|
||||
dup (inc-reg-class)
|
||||
fp-shadows-int? [ reg-size 4 / int-regs +@ ] [ drop ] if ;
|
||||
fp-shadows-int? [ reg-size cell /i int-regs +@ ] [ drop ] if ;
|
||||
|
||||
: reg-class-full? ( class -- ? )
|
||||
dup class get swap param-regs length >= ;
|
||||
|
|
|
|||
|
|
@ -8,3 +8,5 @@ USING: kernel vocabs vocabs.loader sequences ;
|
|||
"ui.cocoa.tools" require
|
||||
] when
|
||||
] when
|
||||
|
||||
macosx? [ "ui.tools.deploy" require ] when
|
||||
|
|
|
|||
|
|
@ -278,7 +278,7 @@ M: arm-backend %alien-indirect ( -- )
|
|||
|
||||
M: arm-backend %alien-callback ( quot -- )
|
||||
R0 load-indirect
|
||||
"run_callback" f %alien-invoke ;
|
||||
"c_to_factor" f %alien-invoke ;
|
||||
|
||||
M: arm-backend %callback-value ( ctype -- )
|
||||
! Save top of data stack
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@
|
|||
USING: alien alien.c-types kernel math namespaces
|
||||
cpu.architecture cpu.arm.architecture cpu.arm.assembler
|
||||
cpu.arm.intrinsics generator generator.registers continuations
|
||||
compiler io vocabs.loader sequences ;
|
||||
compiler io vocabs.loader sequences system ;
|
||||
|
||||
! EABI passes floats in integer registers.
|
||||
[ alien-float ]
|
||||
|
|
@ -53,4 +53,4 @@ T{ arm-backend } compiler-backend set-global
|
|||
t have-BLX? set-global
|
||||
] when
|
||||
|
||||
7 cells set-profiler-prologue
|
||||
7 cells set-profiler-prologues
|
||||
|
|
|
|||
|
|
@ -160,7 +160,7 @@ HOOK: %unbox-struct-2 compiler-backend ( -- )
|
|||
|
||||
M: x86-backend %unbox-small-struct ( size -- )
|
||||
#! Alien must be in EAX.
|
||||
cell align cell / {
|
||||
cell align cell /i {
|
||||
{ 1 [ %unbox-struct-1 ] }
|
||||
{ 2 [ %unbox-struct-2 ] }
|
||||
} case ;
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
IN: temporary
|
||||
USING: arrays generic kernel math models namespaces sequences
|
||||
tools.test ;
|
||||
tools.test assocs ;
|
||||
|
||||
TUPLE: model-tester hit? ;
|
||||
|
||||
|
|
@ -106,3 +106,34 @@ f <history> "history" set
|
|||
[ { 4 5 } ] [ "c" get model-value ] unit-test
|
||||
|
||||
[ ] [ "c" get deactivate-model ] unit-test
|
||||
|
||||
! Test mapping
|
||||
[ ] [
|
||||
[
|
||||
1 <model> "one" set
|
||||
2 <model> "two" set
|
||||
] H{ } make-assoc
|
||||
<mapping> "m" set
|
||||
] unit-test
|
||||
|
||||
[ ] [ "m" get activate-model ] unit-test
|
||||
|
||||
[ H{ { "one" 1 } { "two" 2 } } ] [
|
||||
"m" get model-value
|
||||
] unit-test
|
||||
|
||||
[ ] [
|
||||
H{ { "one" 3 } { "two" 4 } }
|
||||
"m" get set-model
|
||||
] unit-test
|
||||
|
||||
[ H{ { "one" 3 } { "two" 4 } } ] [
|
||||
"m" get model-value
|
||||
] unit-test
|
||||
|
||||
[ H{ { "one" 5 } { "two" 4 } } ] [
|
||||
5 "one" "m" get mapping-assoc at set-model
|
||||
"m" get model-value
|
||||
] unit-test
|
||||
|
||||
[ ] [ "m" get deactivate-model ] unit-test
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2006, 2007 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: generic kernel math sequences timers arrays ;
|
||||
USING: generic kernel math sequences timers arrays assocs ;
|
||||
IN: models
|
||||
|
||||
TUPLE: model value connections dependencies ref ;
|
||||
|
|
@ -109,6 +109,22 @@ M: compose model-activated model-changed ;
|
|||
|
||||
M: compose set-model [ set-model ] set-composed-value ;
|
||||
|
||||
TUPLE: mapping assoc ;
|
||||
|
||||
: <mapping> ( models -- mapping )
|
||||
f mapping construct-model
|
||||
over values over set-model-dependencies
|
||||
tuck set-mapping-assoc ;
|
||||
|
||||
M: mapping model-changed
|
||||
dup mapping-assoc [ model-value ] assoc-map
|
||||
swap delegate set-model ;
|
||||
|
||||
M: mapping model-activated model-changed ;
|
||||
|
||||
M: mapping set-model
|
||||
mapping-assoc [ swapd at set-model ] curry assoc-each ;
|
||||
|
||||
TUPLE: history back forward ;
|
||||
|
||||
: reset-history ( history -- )
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
! Portions copyright (C) 2007 Eduardo Cavazos.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien alien.c-types io kernel math namespaces
|
||||
sequences math.vectors opengl.gl opengl.glu combinators ;
|
||||
sequences math.vectors math.constants math.functions opengl.gl opengl.glu combinators arrays ;
|
||||
IN: opengl
|
||||
|
||||
: coordinates [ first2 ] 2apply ;
|
||||
|
|
@ -63,6 +63,23 @@ IN: opengl
|
|||
: gl-poly ( points -- )
|
||||
GL_LINE_LOOP (gl-poly) ;
|
||||
|
||||
: circle-steps dup length v/n 2 pi * v*n ;
|
||||
|
||||
: unit-circle dup [ sin ] map swap [ cos ] map ;
|
||||
|
||||
: adjust-points [ [ 1 + 0.5 * ] map ] 2apply ;
|
||||
|
||||
: scale-points 2array flip [ v* ] curry* map [ v+ ] curry* map ;
|
||||
|
||||
: circle-points ( loc dim steps -- points )
|
||||
circle-steps unit-circle adjust-points scale-points ;
|
||||
|
||||
: gl-circle ( loc dim steps -- )
|
||||
circle-points gl-poly ;
|
||||
|
||||
: gl-fill-circle ( loc dim steps -- )
|
||||
circle-points gl-fill-poly ;
|
||||
|
||||
: prepare-gradient ( direction dim -- v1 v2 )
|
||||
tuck v* [ v- ] keep ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
USING: help.markup help.syntax words alien.c-types assocs
|
||||
kernel ;
|
||||
kernel math ;
|
||||
IN: tools.deploy.config
|
||||
|
||||
ARTICLE: "deploy-config" "Deployment configuration"
|
||||
|
|
@ -14,17 +14,13 @@ ARTICLE: "deploy-config" "Deployment configuration"
|
|||
ARTICLE: "deploy-flags" "Deployment flags"
|
||||
"There are two types of flags. The first set controls the major subsystems which are to be included in the deployment image:"
|
||||
{ $subsection deploy-math? }
|
||||
{ $subsection deploy-compiled? }
|
||||
{ $subsection deploy-io? }
|
||||
{ $subsection deploy-compiler? }
|
||||
{ $subsection deploy-ui? }
|
||||
"The second set of flags controls the level of stripping to be performed on the deployment image; there is a trade-off between image size, and retaining functionality which is required by the application:"
|
||||
{ $subsection strip-globals? }
|
||||
{ $subsection strip-word-props? }
|
||||
{ $subsection strip-word-names? }
|
||||
{ $subsection strip-dictionary? }
|
||||
{ $subsection strip-debugger? }
|
||||
{ $subsection strip-prettyprint? }
|
||||
{ $subsection strip-c-types? } ;
|
||||
{ $subsection deploy-io }
|
||||
{ $subsection deploy-reflection }
|
||||
{ $subsection deploy-word-props? }
|
||||
{ $subsection deploy-c-types? } ;
|
||||
|
||||
ARTICLE: "prepare-deploy" "Preparing to deploy an application"
|
||||
"In order to deploy an application as a stand-alone image, the application's vocabulary must first be given a " { $link POSTPONE: MAIN: } " hook. Then, a " { $emphasis "deployment configuration" } " must be created."
|
||||
|
|
@ -33,47 +29,22 @@ ARTICLE: "prepare-deploy" "Preparing to deploy an application"
|
|||
|
||||
ABOUT: "prepare-deploy"
|
||||
|
||||
HELP: strip-globals?
|
||||
{ $description "Deploy flag. If set, the deploy tool applies various heuristics to strip out un-needed variables from the global namespace."
|
||||
HELP: deploy-word-props?
|
||||
{ $description "Deploy flag. If set, the deploy tool retains all word properties. Otherwise, it applies various heuristics to strip out un-needed word properties from words in the dictionary."
|
||||
$nl
|
||||
"On by default. Disable this if the heuristics strip out required variables." } ;
|
||||
"Off by default. Enable this if the heuristics strip out required word properties." } ;
|
||||
|
||||
HELP: strip-word-props?
|
||||
{ $description "Deploy flag. If set, the deploy tool applies various heuristics to strip out un-needed word properties from words in the dictionary."
|
||||
HELP: deploy-c-types?
|
||||
{ $description "Deploy flag. If set, the deploy tool retains the " { $link c-types } " table."
|
||||
$nl
|
||||
"On by default. Disable this if the heuristics strip out required word properties." } ;
|
||||
|
||||
HELP: strip-word-names?
|
||||
{ $description "Deploy flag. If set, the deploy tool strips word names from words in the dictionary."
|
||||
$nl
|
||||
"On by default. Disable this if your program calls " { $link word-name } "." } ;
|
||||
|
||||
HELP: strip-dictionary?
|
||||
{ $description "Deploy flag. If set, the deploy tool strips unused words."
|
||||
$nl
|
||||
"On by default. Disable this if your program calls " { $link lookup } " to look up words by name, or needs to parse code at run-time." } ;
|
||||
|
||||
HELP: strip-debugger?
|
||||
{ $description "Deploy flag. If set, the deploy tool strips the verbose error reporting facility; any errors thrown by the program will start the low-level debugger in the VM."
|
||||
$nl
|
||||
"On by default. Disable this if you need to debug a problem which only occurs when your program is running deployed." } ;
|
||||
|
||||
HELP: strip-prettyprint?
|
||||
{ $description "Deploy flag. If set, the deploy tool strips variables used by the prettyprinter."
|
||||
$nl
|
||||
"On by default. Disable this if your program uses the prettyprinter." } ;
|
||||
|
||||
HELP: strip-c-types?
|
||||
{ $description "Deploy flag. If set, the deploy tool strips out the " { $link c-types } " table."
|
||||
$nl
|
||||
"On by default. Disable this if your program calls " { $link c-type } ", " { $link heap-size } ", " { $link <c-object> } ", " { $link <c-array> } ", " { $link malloc-object } ", or " { $link malloc-array } " with a C type name which is not a literal pushed directly at the call site. In this situation, the compiler is unable to fold away the C type lookup, and thus must use the global table at runtime." } ;
|
||||
"Off by default. Disable this if your program calls " { $link c-type } ", " { $link heap-size } ", " { $link <c-object> } ", " { $link <c-array> } ", " { $link malloc-object } ", or " { $link malloc-array } " with a C type name which is not a literal pushed directly at the call site. In this situation, the compiler is unable to fold away the C type lookup, and thus must use the global table at runtime." } ;
|
||||
|
||||
HELP: deploy-math?
|
||||
{ $description "Deploy flag. If set, the deployed image will contain the full number tower."
|
||||
{ $description "Deploy flag. If set, the deployed image will contain support for " { $link ratio } " and " { $link complex } " types."
|
||||
$nl
|
||||
"On by default. Most programs require the number tower, in particular, any program deployed with " { $link deploy-compiled? } " set." } ;
|
||||
"On by default. Often the programmer will use rationals without realizing it. A small amount of space can be saved by stripping these features out, but some code may require changes to work properly." } ;
|
||||
|
||||
HELP: deploy-compiled?
|
||||
HELP: deploy-compiler?
|
||||
{ $description "Deploy flag. If set, words in the deployed image will be compiled when possible."
|
||||
$nl
|
||||
"On by default. Most programs should be compiled, not only for performance but because features which depend on the C library interface only function after compilation." } ;
|
||||
|
|
@ -83,10 +54,11 @@ HELP: deploy-ui?
|
|||
$nl
|
||||
"Off by default. Programs wishing to use the UI must be deployed with this flag on." } ;
|
||||
|
||||
HELP: deploy-io?
|
||||
{ $description "Deploy flag. If set, support for non-blocking I/O and networking will be included in the deployed image."
|
||||
$nl
|
||||
"Off by default. Programs wishing to use non-blocking I/O or networking must be deployed with this flag on." } ;
|
||||
HELP: deploy-io
|
||||
{ $description "The level of I/O support required by the deployed image." } ;
|
||||
|
||||
HELP: deploy-reflection
|
||||
{ $description "The level of reflection support required by the deployed image." } ;
|
||||
|
||||
HELP: default-config
|
||||
{ $values { "assoc" assoc } }
|
||||
|
|
|
|||
|
|
@ -1,40 +1,59 @@
|
|||
! Copyright (C) 2007 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: vocabs.loader io.files io kernel sequences assocs
|
||||
splitting parser prettyprint ;
|
||||
splitting parser prettyprint namespaces math ;
|
||||
IN: tools.deploy.config
|
||||
|
||||
SYMBOL: strip-io?
|
||||
SYMBOL: strip-globals?
|
||||
SYMBOL: strip-word-props?
|
||||
SYMBOL: strip-word-names?
|
||||
SYMBOL: strip-dictionary?
|
||||
SYMBOL: strip-debugger?
|
||||
SYMBOL: strip-prettyprint?
|
||||
SYMBOL: strip-c-types?
|
||||
|
||||
SYMBOL: deploy-math?
|
||||
SYMBOL: deploy-compiled?
|
||||
SYMBOL: deploy-io?
|
||||
SYMBOL: deploy-ui?
|
||||
SYMBOL: deploy-compiler?
|
||||
SYMBOL: deploy-math?
|
||||
|
||||
SYMBOL: deploy-io
|
||||
|
||||
: deploy-io-options
|
||||
{
|
||||
{ 1 "Level 1 - No input/output" }
|
||||
{ 2 "Level 2 - Basic ANSI C streams" }
|
||||
{ 3 "Level 3 - Non-blocking streams and networking" }
|
||||
} ;
|
||||
|
||||
: strip-io? deploy-io get zero? ;
|
||||
|
||||
: native-io? deploy-io get 3 = ;
|
||||
|
||||
SYMBOL: deploy-reflection
|
||||
|
||||
: deploy-reflection-options
|
||||
{
|
||||
{ 1 "Level 1 - No reflection" }
|
||||
{ 2 "Level 2 - Retain word names" }
|
||||
{ 3 "Level 3 - Prettyprinter" }
|
||||
{ 4 "Level 4 - Debugger" }
|
||||
{ 5 "Level 5 - Parser" }
|
||||
{ 6 "Level 6 - Full environment" }
|
||||
} ;
|
||||
|
||||
: strip-word-names? deploy-reflection get 2 < ;
|
||||
: strip-prettyprint? deploy-reflection get 3 < ;
|
||||
: strip-debugger? deploy-reflection get 4 < ;
|
||||
: strip-dictionary? deploy-reflection get 5 < ;
|
||||
: strip-globals? deploy-reflection get 6 < ;
|
||||
|
||||
SYMBOL: deploy-word-props?
|
||||
SYMBOL: deploy-c-types?
|
||||
|
||||
SYMBOL: deploy-vm
|
||||
SYMBOL: deploy-image
|
||||
|
||||
: default-config ( -- assoc )
|
||||
V{
|
||||
{ strip-io? f }
|
||||
{ strip-prettyprint? t }
|
||||
{ strip-globals? t }
|
||||
{ strip-word-props? t }
|
||||
{ strip-word-names? t }
|
||||
{ strip-dictionary? t }
|
||||
{ strip-debugger? t }
|
||||
{ strip-c-types? t }
|
||||
{ deploy-math? t }
|
||||
{ deploy-compiled? t }
|
||||
{ deploy-io? f }
|
||||
{ deploy-ui? f }
|
||||
{ deploy-ui? f }
|
||||
{ deploy-io 2 }
|
||||
{ deploy-reflection 1 }
|
||||
{ deploy-compiler? t }
|
||||
{ deploy-math? t }
|
||||
{ deploy-word-props? f }
|
||||
{ deploy-c-types? f }
|
||||
! default value for deploy.app
|
||||
{ "stop-after-last-window?" t }
|
||||
} clone ;
|
||||
|
|
|
|||
|
|
@ -30,13 +30,16 @@ IN: tools.deploy
|
|||
dup duplex-stream-out stream-close
|
||||
copy-lines ;
|
||||
|
||||
: ?append swap [ append ] [ drop ] if ;
|
||||
|
||||
: profile-string ( config -- string )
|
||||
{
|
||||
{ deploy-math? "math" }
|
||||
{ deploy-compiled? "compiler" }
|
||||
{ deploy-ui? "ui" }
|
||||
{ deploy-io? "io" }
|
||||
} swap [ nip at ] curry assoc-subset values " " join ;
|
||||
[
|
||||
""
|
||||
deploy-math? get " math" ?append
|
||||
deploy-compiler? get " compiler" ?append
|
||||
native-io? " io" ?append
|
||||
deploy-ui? get " ui" ?append
|
||||
] bind ;
|
||||
|
||||
: deploy-command-line ( vm image vocab config -- vm flags )
|
||||
[
|
||||
|
|
|
|||
|
|
@ -16,10 +16,10 @@ IN: tools.deploy.shaker
|
|||
: strip-init-hooks ( -- )
|
||||
"Stripping startup hooks" show
|
||||
"command-line" init-hooks get delete-at
|
||||
strip-io? get [ "io.backend" init-hooks get delete-at ] when ;
|
||||
strip-io? [ "io.backend" init-hooks get delete-at ] when ;
|
||||
|
||||
: strip-debugger ( -- )
|
||||
strip-debugger? get [
|
||||
strip-debugger? [
|
||||
"Stripping debugger" show
|
||||
"resource:extra/tools/deploy/shaker/strip-debugger.factor"
|
||||
run-file
|
||||
|
|
@ -65,23 +65,13 @@ IN: tools.deploy.shaker
|
|||
|
||||
: strip-words ( props -- )
|
||||
[ word? ] instances
|
||||
strip-word-props? get [ tuck strip-word-props ] [ nip ] if
|
||||
strip-word-names? get [ dup strip-word-names ] when
|
||||
deploy-word-props? get [ nip ] [ tuck strip-word-props ] if
|
||||
strip-word-names? [ dup strip-word-names ] when
|
||||
strip-word-defs ;
|
||||
|
||||
USING: bit-arrays byte-arrays io.streams.nested ;
|
||||
|
||||
: strip-classes ( -- )
|
||||
"Stripping classes" show
|
||||
io-backend get [
|
||||
c-reader forget
|
||||
c-writer forget
|
||||
] when
|
||||
{ style-stream mirror enum } [ forget ] each ;
|
||||
|
||||
: strip-environment ( retain-globals -- )
|
||||
"Stripping environment" show
|
||||
strip-globals? get [
|
||||
strip-globals? [
|
||||
global strip-assoc 21 setenv
|
||||
] [ drop ] if ;
|
||||
|
||||
|
|
@ -103,16 +93,16 @@ SYMBOL: deploy-vocab
|
|||
\ boot ,
|
||||
init-hooks get values concat %
|
||||
,
|
||||
strip-io? get [ \ flush , ] unless
|
||||
strip-io? [ \ flush , ] unless
|
||||
] [ ] make "Boot quotation: " write dup . flush
|
||||
set-boot-quot ;
|
||||
|
||||
: retained-globals ( -- seq )
|
||||
[
|
||||
builtins ,
|
||||
strip-io? get [ io-backend , ] unless
|
||||
strip-io? [ io-backend , ] unless
|
||||
|
||||
strip-dictionary? get [
|
||||
strip-dictionary? [
|
||||
{
|
||||
builtins
|
||||
dictionary
|
||||
|
|
@ -129,14 +119,14 @@ SYMBOL: deploy-vocab
|
|||
} %
|
||||
] unless
|
||||
|
||||
strip-prettyprint? get [
|
||||
strip-prettyprint? [
|
||||
{
|
||||
tab-size
|
||||
margin
|
||||
} %
|
||||
] unless
|
||||
|
||||
strip-c-types? get not deploy-ui? get or [
|
||||
deploy-c-types? get deploy-ui? get or [
|
||||
"c-types" "alien.c-types" lookup ,
|
||||
] when
|
||||
|
||||
|
|
@ -150,18 +140,7 @@ SYMBOL: deploy-vocab
|
|||
] when
|
||||
] { } make dup . ;
|
||||
|
||||
: normalize-strip-flags
|
||||
strip-prettyprint? get [
|
||||
strip-word-names? off
|
||||
] unless
|
||||
strip-dictionary? get [
|
||||
strip-prettyprint? off
|
||||
strip-word-names? off
|
||||
strip-word-props? off
|
||||
] unless ;
|
||||
|
||||
: strip ( -- )
|
||||
normalize-strip-flags
|
||||
strip-cocoa
|
||||
strip-debugger
|
||||
strip-init-hooks
|
||||
|
|
|
|||
|
|
@ -4,23 +4,41 @@ USING: arrays ui.gadgets generic hashtables kernel math
|
|||
namespaces vectors sequences math.vectors ;
|
||||
IN: ui.gadgets.borders
|
||||
|
||||
TUPLE: border size ;
|
||||
TUPLE: border size fill ;
|
||||
|
||||
: <border> ( child gap -- border )
|
||||
border construct-gadget
|
||||
[ >r dup 2array r> set-border-size ] keep
|
||||
[ add-gadget ] keep ;
|
||||
|
||||
: layout-border-loc ( border -- )
|
||||
dup rect-dim swap gadget-child
|
||||
[ pref-dim v- 2 v/n [ >fixnum ] map ] keep set-rect-loc ;
|
||||
dup 2array { 0 0 } border construct-boa
|
||||
<gadget> over set-delegate
|
||||
tuck add-gadget ;
|
||||
|
||||
M: border pref-dim*
|
||||
[ border-size 2 v*n ] keep
|
||||
gadget-child pref-dim v+ ;
|
||||
|
||||
: border-major-rect ( border -- rect )
|
||||
dup border-size swap rect-dim over 2 v*n v- <rect> ;
|
||||
|
||||
: border-minor-rect ( major border -- rect )
|
||||
gadget-child pref-dim
|
||||
[ >r rect-bounds r> v- 2 v/n v+ ] keep <rect> ;
|
||||
|
||||
: scale-rect ( rect vec -- loc dim )
|
||||
[ v* ] curry >r rect-bounds r> 2apply ;
|
||||
|
||||
: average-rects ( rect1 rect2 weight -- rect )
|
||||
tuck >r >r scale-rect r> r> { 1 1 } swap v- scale-rect
|
||||
swapd v+ >r v+ r> <rect> ;
|
||||
|
||||
: border-child-rect ( border -- rect )
|
||||
dup border-major-rect
|
||||
dup pick border-minor-rect
|
||||
rot border-fill
|
||||
average-rects ;
|
||||
|
||||
M: border layout*
|
||||
dup layout-border-loc gadget-child prefer ;
|
||||
dup border-child-rect swap gadget-child
|
||||
over rect-loc over set-rect-loc
|
||||
swap rect-dim swap set-layout-dim ;
|
||||
|
||||
M: border focusable-child*
|
||||
gadget-child ;
|
||||
|
|
|
|||
|
|
@ -7,11 +7,7 @@ HELP: button
|
|||
$nl
|
||||
"A button's appearance can vary depending on the state of the mouse button if the " { $link gadget-interior } " or " { $link gadget-boundary } " slots are set to instances of " { $link button-paint } "."
|
||||
$nl
|
||||
"A button can be selected, which is distinct from being pressed. This state is held in the " { $link button-selected? } " slot, and is used by the " { $link <radio-box> } " word to construct a row of buttons for choosing among several alternatives." } ;
|
||||
|
||||
HELP: >label
|
||||
{ $values { "obj" "a label specifier" } { "gadget" "a new " { $link gadget } } }
|
||||
{ $description "Convert the object into a gadget suitable for use as the label of a button. If " { $snippet "obj" } " is already a gadget, does nothing. Otherwise creates a " { $link label } " gadget if it is a string and an empty gadget if " { $snippet "obj" } " is " { $link f } "." } ;
|
||||
"A button can be selected, which is distinct from being pressed. This state is held in the " { $link button-selected? } " slot, and is used by the " { $link <toggle-buttons> } " word to construct a row of buttons for choosing among several alternatives." } ;
|
||||
|
||||
HELP: <button>
|
||||
{ $values { "gadget" gadget } { "quot" "a quotation with stack effect " { $snippet "( button -- )" } } { "button" "a new " { $link button } } }
|
||||
|
|
@ -35,20 +31,20 @@ HELP: button-paint
|
|||
{ { $link button-paint-plain } " - the button is inactive" }
|
||||
{ { $link button-paint-rollover } " - the button is under the mouse" }
|
||||
{ { $link button-paint-pressed } " - the button is under the mouse and a mouse button is held down" }
|
||||
{ { $link button-paint-selected } " - the button is selected (see " { $link <radio-box> } }
|
||||
{ { $link button-paint-selected } " - the button is selected (see " { $link <toggle-buttons> } }
|
||||
}
|
||||
"The " { $link <roll-button> } " and " { $link <bevel-button> } " words create " { $link button } " instances with specific " { $link button-paint } "." } ;
|
||||
|
||||
HELP: <radio-control>
|
||||
HELP: <toggle-button>
|
||||
{ $values { "model" model } { "value" object } { "label" "a label specifier" } { "gadget" gadget } }
|
||||
{ $description
|
||||
"Creates a " { $link <bevel-button> } " which sets the model's value to " { $snippet "value" } " when pressed. After being pressed, the button becomes selected until the value of the model changes again."
|
||||
}
|
||||
{ $notes "Typically a row of radio controls should be built together using " { $link <radio-box> } "." } ;
|
||||
{ $notes "Typically a row of radio controls should be built together using " { $link <toggle-buttons> } "." } ;
|
||||
|
||||
HELP: <radio-box>
|
||||
HELP: <toggle-buttons>
|
||||
{ $values { "model" model } { "assoc" "an association list mapping labels to objects" } { "gadget" gadget } }
|
||||
{ $description "Creates a row of labelled " { $link <radio-control> } " gadgets which change the value of the model." } ;
|
||||
{ $description "Creates a row of labelled " { $link <toggle-button> } " gadgets which change the value of the model." } ;
|
||||
|
||||
HELP: <command-button>
|
||||
{ $values { "target" object } { "gesture" "a gesture" } { "command" "a command" } { "button" "a new " { $link button } } }
|
||||
|
|
@ -74,11 +70,8 @@ ARTICLE: "ui.gadgets.buttons" "Button gadgets"
|
|||
{ $subsection <command-button> }
|
||||
{ $subsection <toolbar> }
|
||||
"A radio box is a row of buttons for choosing amongst several distinct possibilities:"
|
||||
{ $subsection <radio-box> }
|
||||
{ $subsection <toggle-buttons> }
|
||||
"Button appearance can be customized:"
|
||||
{ $subsection button-paint }
|
||||
"Button constructors take " { $emphasis "label specifiers" } " as input. A label specifier is either a string, an array of strings, a gadget or " { $link f } "."
|
||||
$nl
|
||||
"A generic word used to convert label specifiers to gadgets:"
|
||||
{ $subsection >label }
|
||||
{ $see-also <command-button> "ui-commands" } ;
|
||||
|
|
|
|||
|
|
@ -4,7 +4,7 @@ USING: arrays ui.commands ui.gadgets ui.gadgets.borders
|
|||
ui.gadgets.controls ui.gadgets.labels ui.gadgets.theme
|
||||
ui.gadgets.tracks ui.gadgets.packs ui.gadgets.worlds ui.gestures
|
||||
ui.render kernel math models namespaces sequences strings
|
||||
quotations assocs combinators classes colors ;
|
||||
quotations assocs combinators classes colors tuples ;
|
||||
IN: ui.gadgets.buttons
|
||||
|
||||
TUPLE: button pressed? selected? quot ;
|
||||
|
|
@ -38,12 +38,6 @@ button H{
|
|||
{ T{ mouse-enter } [ button-update ] }
|
||||
} set-gestures
|
||||
|
||||
GENERIC: >label ( obj -- gadget )
|
||||
M: string >label <label> ;
|
||||
M: array >label <label> ;
|
||||
M: object >label ;
|
||||
M: f >label drop <gadget> ;
|
||||
|
||||
: <button> ( gadget quot -- button )
|
||||
button construct-empty
|
||||
[ set-button-quot ] keep
|
||||
|
|
@ -53,12 +47,14 @@ TUPLE: button-paint plain rollover pressed selected ;
|
|||
|
||||
C: <button-paint> button-paint
|
||||
|
||||
: find-button [ [ button? ] is? ] find-parent ;
|
||||
|
||||
: button-paint ( button paint -- button paint )
|
||||
{
|
||||
{ [ over button-pressed? ] [ button-paint-pressed ] }
|
||||
{ [ over button-selected? ] [ button-paint-selected ] }
|
||||
{ [ over button-rollover? ] [ button-paint-rollover ] }
|
||||
{ [ t ] [ button-paint-plain ] }
|
||||
over find-button {
|
||||
{ [ dup button-pressed? ] [ drop button-paint-pressed ] }
|
||||
{ [ dup button-selected? ] [ drop button-paint-selected ] }
|
||||
{ [ dup button-rollover? ] [ drop button-paint-rollover ] }
|
||||
{ [ t ] [ drop button-paint-plain ] }
|
||||
} cond ;
|
||||
|
||||
M: button-paint draw-interior
|
||||
|
|
@ -99,14 +95,78 @@ repeat-button H{
|
|||
repeat-button construct-empty
|
||||
[ >r <bevel-button> r> set-gadget-delegate ] keep ;
|
||||
|
||||
: <radio-control> ( model value label -- gadget )
|
||||
over [ swap set-control-value ] curry <bevel-button>
|
||||
swap [ swap >r = r> set-button-selected? ] curry <control> ;
|
||||
: checkmark-theme ( gadget -- )
|
||||
f
|
||||
f
|
||||
black <solid>
|
||||
black <checkmark-paint>
|
||||
<button-paint>
|
||||
over set-gadget-interior
|
||||
black <solid>
|
||||
swap set-gadget-boundary ;
|
||||
|
||||
: <radio-box> ( model assoc -- gadget )
|
||||
[
|
||||
swap [ -rot <radio-control> gadget, ] curry assoc-each
|
||||
] make-shelf ;
|
||||
: <checkmark> ( -- gadget )
|
||||
<gadget>
|
||||
dup checkmark-theme
|
||||
{ 14 14 } over set-gadget-dim ;
|
||||
|
||||
: toggle-model ( model -- )
|
||||
[ not ] change-model ;
|
||||
|
||||
: checkbox-theme
|
||||
f over set-gadget-interior
|
||||
{ 5 5 } over set-pack-gap
|
||||
1/2 swap set-pack-align ;
|
||||
|
||||
: <checkbox> ( model label -- checkbox )
|
||||
<checkmark>
|
||||
label-on-right
|
||||
over [ toggle-model drop ] curry <button>
|
||||
[ set-button-selected? ] <control>
|
||||
dup checkbox-theme ;
|
||||
|
||||
: radio-knob-theme ( gadget -- )
|
||||
f
|
||||
f
|
||||
black <radio-paint>
|
||||
black <radio-paint>
|
||||
<button-paint>
|
||||
over set-gadget-interior
|
||||
black <radio-paint>
|
||||
swap set-gadget-boundary ;
|
||||
|
||||
: <radio-knob> ( -- gadget )
|
||||
<gadget>
|
||||
dup radio-knob-theme
|
||||
{ 16 16 } over set-gadget-dim ;
|
||||
|
||||
: <radio-control> ( model value gadget quot -- control )
|
||||
>r dupd [ set-control-value ] curry* r> call
|
||||
[ >r = r> set-button-selected? ] curry* <control> ; inline
|
||||
|
||||
: <radio-controls> ( model assoc quot -- gadget )
|
||||
swapd [ >r -rot r> call gadget, ] 2curry assoc-each ; inline
|
||||
|
||||
: radio-button-theme
|
||||
{ 5 5 } over set-pack-gap 1/2 swap set-pack-align ;
|
||||
|
||||
: <radio-button> ( model value label -- gadget )
|
||||
<radio-knob> label-on-right
|
||||
[ <button> ] <radio-control>
|
||||
dup radio-button-theme ;
|
||||
|
||||
: radio-buttons-theme
|
||||
{ 5 5 } swap set-pack-gap ;
|
||||
|
||||
: <radio-buttons> ( model assoc -- gadget )
|
||||
[ [ <radio-button> ] <radio-controls> ] make-filled-pile
|
||||
dup radio-buttons-theme ;
|
||||
|
||||
: <toggle-button> ( model value label -- gadget )
|
||||
[ <bevel-button> ] <radio-control> ;
|
||||
|
||||
: <toggle-buttons> ( model assoc -- gadget )
|
||||
[ [ <toggle-button> ] <radio-controls> ] make-shelf ;
|
||||
|
||||
: command-button-quot ( target command -- quot )
|
||||
[ invoke-command drop ] 2curry ;
|
||||
|
|
|
|||
|
|
@ -34,6 +34,9 @@ TUPLE: loc-monitor editor ;
|
|||
dup init-editor-locs
|
||||
dup editor-theme ;
|
||||
|
||||
: field-theme ( gadget -- )
|
||||
gray <solid> swap set-gadget-boundary ;
|
||||
|
||||
: construct-editor ( class -- tuple )
|
||||
>r <editor> { set-gadget-delegate } r>
|
||||
(construct-control) ; inline
|
||||
|
|
@ -425,3 +428,28 @@ M: editor stream-write
|
|||
M: editor stream-close drop ;
|
||||
|
||||
M: editor stream-flush drop ;
|
||||
|
||||
! Fields are like editors except they edit an external model
|
||||
TUPLE: field model editor ;
|
||||
|
||||
: <field-border> ( gadget -- border )
|
||||
2 <border>
|
||||
{ 1 0 } over set-border-fill
|
||||
dup field-theme ;
|
||||
|
||||
: <field> ( model -- gadget )
|
||||
<editor> dup <field-border>
|
||||
{ set-field-model set-field-editor set-gadget-delegate }
|
||||
field construct ;
|
||||
|
||||
M: field graft*
|
||||
dup field-model model-value
|
||||
over field-editor set-editor-string
|
||||
dup field-editor control-model add-connection ;
|
||||
|
||||
M: field ungraft*
|
||||
dup field-editor control-model remove-connection ;
|
||||
|
||||
M: field model-changed
|
||||
dup field-editor editor-string
|
||||
swap field-model set-model ;
|
||||
|
|
|
|||
|
|
@ -30,6 +30,12 @@ ARTICLE: "ui.gadgets.labels" "Label gadgets"
|
|||
{ $subsection <label> }
|
||||
{ $subsection <label-control> }
|
||||
{ $subsection label-string }
|
||||
{ $subsection set-label-string } ;
|
||||
{ $subsection set-label-string }
|
||||
"Label specifiers are used by buttons, checkboxes and radio buttons:"
|
||||
{ $subsection >label } ;
|
||||
|
||||
ABOUT: "ui.gadgets.labels"
|
||||
|
||||
HELP: >label
|
||||
{ $values { "obj" "a label specifier" } { "gadget" "a new " { $link gadget } } }
|
||||
{ $description "Convert the object into a gadget suitable for use as the label of a button. If " { $snippet "obj" } " is already a gadget, does nothing. Otherwise creates a " { $link label } " gadget if it is a string and an empty gadget if " { $snippet "obj" } " is " { $link f } "." } ;
|
||||
|
|
|
|||
|
|
@ -2,8 +2,8 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays hashtables io kernel math namespaces
|
||||
opengl sequences io.streams.lines strings splitting
|
||||
ui.gadgets ui.gadgets.controls ui.gadgets.theme ui.render
|
||||
colors ;
|
||||
ui.gadgets ui.gadgets.controls ui.gadgets.tracks
|
||||
ui.gadgets.theme ui.render colors ;
|
||||
IN: ui.gadgets.labels
|
||||
|
||||
! A label gadget draws a string.
|
||||
|
|
@ -47,3 +47,15 @@ M: label gadget-text* label-string % ;
|
|||
: reverse-video-theme ( label -- )
|
||||
white over set-label-color
|
||||
black solid-interior ;
|
||||
|
||||
GENERIC: >label ( obj -- gadget )
|
||||
M: string >label <label> ;
|
||||
M: array >label <label> ;
|
||||
M: object >label ;
|
||||
M: f >label drop <gadget> ;
|
||||
|
||||
: label-on-left ( gadget label -- button )
|
||||
[ >label f track, 1 track, ] { 1 0 } make-track ;
|
||||
|
||||
: label-on-right ( label gadget -- button )
|
||||
[ f track, >label 1 track, ] { 1 0 } make-track ;
|
||||
|
|
|
|||
|
|
@ -71,3 +71,7 @@ M: pack children-on ( rect gadget -- seq )
|
|||
|
||||
: make-shelf ( quot -- pack )
|
||||
<shelf> make-gadget ; inline
|
||||
|
||||
: build-pack ( quot quot orientation -- pack )
|
||||
<pack> build-gadget ; inline
|
||||
|
||||
|
|
|
|||
|
|
@ -95,7 +95,6 @@ SYMBOL: ui-error-hook
|
|||
] [
|
||||
over <world-error> ui-error
|
||||
f swap set-world-active?
|
||||
drop
|
||||
] recover
|
||||
] with-variable
|
||||
] [
|
||||
|
|
|
|||
|
|
@ -140,6 +140,33 @@ M: polygon draw-interior
|
|||
>r <polygon> <gadget> r> over set-rect-dim
|
||||
[ set-gadget-interior ] keep ;
|
||||
|
||||
! Checkbox and radio button pens
|
||||
TUPLE: checkmark-paint color ;
|
||||
|
||||
C: <checkmark-paint> checkmark-paint
|
||||
|
||||
M: checkmark-paint draw-interior
|
||||
checkmark-paint-color gl-color
|
||||
origin get [
|
||||
rect-dim
|
||||
{ 0 0 } over gl-line
|
||||
dup { 0 1 } v* swap { 1 0 } v* gl-line
|
||||
] with-translation ;
|
||||
|
||||
|
||||
TUPLE: radio-paint color ;
|
||||
|
||||
C: <radio-paint> radio-paint
|
||||
|
||||
M: radio-paint draw-interior
|
||||
radio-paint-color gl-color
|
||||
origin get { 4 4 } v+ swap rect-dim { 8 8 } v- 12 gl-fill-circle ;
|
||||
|
||||
M: radio-paint draw-boundary
|
||||
radio-paint-color gl-color
|
||||
origin get { 1 1 } v+ swap rect-dim { 2 2 } v- 12 gl-circle ;
|
||||
|
||||
! Font rendering
|
||||
SYMBOL: font-renderer
|
||||
|
||||
HOOK: open-font font-renderer ( font -- open-font )
|
||||
|
|
|
|||
|
|
@ -0,0 +1,112 @@
|
|||
! Copyright (C) 2007 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: ui.gadgets colors kernel ui.render namespaces
|
||||
ui.gadgets.controls models sequences ui.gadgets.buttons
|
||||
ui.gadgets.packs ui.gadgets.labels tools.deploy.config
|
||||
namespaces ui.gadgets.editors ui.gadgets.borders ui.gestures
|
||||
ui.commands assocs ui.gadgets.tracks ui ui.tools.listener
|
||||
tools.deploy.app vocabs ui.tools.workspace ui.operations ;
|
||||
IN: ui.tools.deploy
|
||||
|
||||
TUPLE: deploy-gadget vocab settings ;
|
||||
|
||||
: bundle-name ( -- )
|
||||
"bundle-name" get <field>
|
||||
"Bundle name:" label-on-left gadget, ;
|
||||
|
||||
: deploy-ui ( -- )
|
||||
deploy-ui? get
|
||||
"Include user interface framework" <checkbox> gadget, ;
|
||||
|
||||
: exit-when-windows-closed ( -- )
|
||||
"stop-after-last-window?" get
|
||||
"Exit when last UI window closed" <checkbox> gadget, ;
|
||||
|
||||
: io-settings ( -- )
|
||||
"Input/output support:" <label> gadget,
|
||||
deploy-io get deploy-io-options <radio-buttons> gadget, ;
|
||||
|
||||
: reflection-settings ( -- )
|
||||
"Reflection support:" <label> gadget,
|
||||
deploy-reflection get deploy-reflection-options <radio-buttons> gadget, ;
|
||||
|
||||
: advanced-settings ( -- )
|
||||
"Advanced:" <label> gadget,
|
||||
deploy-compiler? get "Use optimizing compiler" <checkbox> gadget,
|
||||
deploy-math? get "Rational and complex number support" <checkbox> gadget,
|
||||
deploy-word-props? get "Include word properties" <checkbox> gadget,
|
||||
deploy-c-types? get "Include C types" <checkbox> gadget, ;
|
||||
|
||||
: deploy-settings-theme
|
||||
{ 10 10 } over set-pack-gap
|
||||
1 swap set-pack-fill ;
|
||||
|
||||
: <deploy-settings> ( -- control )
|
||||
default-config [ <model> ] assoc-map [
|
||||
f <model> "bundle-name" set
|
||||
[
|
||||
bundle-name
|
||||
deploy-ui
|
||||
exit-when-windows-closed
|
||||
io-settings
|
||||
reflection-settings
|
||||
advanced-settings
|
||||
] make-pile dup deploy-settings-theme
|
||||
namespace <mapping> swap [ 2drop ] <control>
|
||||
] bind ;
|
||||
|
||||
: find-deploy-gadget
|
||||
[ deploy-gadget? ] find-parent ;
|
||||
|
||||
: find-deploy-vocab
|
||||
find-deploy-gadget deploy-gadget-vocab ;
|
||||
|
||||
: find-deploy-config
|
||||
find-deploy-vocab deploy.app-config ;
|
||||
|
||||
: find-deploy-settings
|
||||
find-deploy-gadget deploy-gadget-settings ;
|
||||
|
||||
: com-revert ( gadget -- )
|
||||
dup find-deploy-config
|
||||
swap find-deploy-settings set-control-value ;
|
||||
|
||||
: com-save ( gadget -- )
|
||||
dup find-deploy-settings control-value
|
||||
swap find-deploy-vocab set-deploy-config ;
|
||||
|
||||
: com-deploy ( gadget -- )
|
||||
dup com-save
|
||||
find-deploy-vocab [ deploy.app ] curry call-listener ;
|
||||
|
||||
: com-help ( -- )
|
||||
"ui-deploy" help-window ;
|
||||
|
||||
\ com-help H{
|
||||
{ +nullary+ t }
|
||||
} define-command
|
||||
|
||||
deploy-gadget "toolbar" f {
|
||||
{ f com-help }
|
||||
{ f com-revert }
|
||||
{ f com-save }
|
||||
{ T{ key-down f f "RETURN" } com-deploy }
|
||||
} define-command-map
|
||||
|
||||
: buttons,
|
||||
g <toolbar> { 10 10 } over set-pack-gap gadget, ;
|
||||
|
||||
: <deploy-gadget> ( vocab -- gadget )
|
||||
f deploy-gadget construct-boa [
|
||||
<deploy-settings>
|
||||
g-> set-deploy-gadget-settings gadget,
|
||||
buttons,
|
||||
] { 0 1 } build-pack
|
||||
dup deploy-settings-theme
|
||||
dup com-revert ;
|
||||
|
||||
: deploy-tool ( vocab -- )
|
||||
vocab-name dup <deploy-gadget> 10 <border>
|
||||
"Deploying \"" rot "\"" 3append open-window ;
|
||||
|
||||
[ vocab-spec? ] \ deploy-tool H{ } define-operation
|
||||
|
|
@ -181,13 +181,8 @@ M: word com-stack-effect word-def com-stack-effect ;
|
|||
} define-operation
|
||||
|
||||
! Profiler presentations
|
||||
[ usage-profile? ] \ com-show-profile H{
|
||||
{ +primary+ t }
|
||||
} define-operation
|
||||
|
||||
[ vocab-profile? ] \ com-show-profile H{
|
||||
{ +primary+ t }
|
||||
} define-operation
|
||||
[ dup usage-profile? swap vocab-profile? or ]
|
||||
\ com-show-profile H{ { +primary+ t } } define-operation
|
||||
|
||||
! Operations -> commands
|
||||
source-editor
|
||||
|
|
|
|||
|
|
@ -9,7 +9,7 @@ ui.gadgets.books ui.gadgets.buttons ui.gadgets.controls
|
|||
ui.gadgets.labelled ui.gadgets.scrollers ui.gadgets.tracks
|
||||
ui.gadgets.worlds ui.gadgets.presentations ui.gestures words
|
||||
vocabs.loader tools.test ui.gadgets.buttons
|
||||
ui.gadgets.status-bar ;
|
||||
ui.gadgets.status-bar mirrors ;
|
||||
IN: ui.tools
|
||||
|
||||
: workspace-tabs ( -- seq )
|
||||
|
|
@ -24,9 +24,8 @@ IN: ui.tools
|
|||
: <workspace-tabs> ( -- tabs )
|
||||
g control-model
|
||||
"tool-switching" workspace command-map
|
||||
[ command-string ] { } assoc>map
|
||||
[ length ] keep 2array flip
|
||||
<radio-box> ;
|
||||
[ command-string ] { } assoc>map <enum> >alist
|
||||
<toggle-buttons> ;
|
||||
|
||||
: <workspace-book> ( -- gadget )
|
||||
workspace-tabs [ execute ] map g control-model <book> ;
|
||||
|
|
|
|||
Loading…
Reference in New Issue