Merge git://factorcode.org/git/factor
Doug Coleman
commit
3032a54c2a
|
|
@ -14,3 +14,4 @@ factor
|
|||
.DS_Store
|
||||
.gdb_history
|
||||
*.*.marks
|
||||
.*.swp
|
||||
|
|
|
|||
2
Makefile
2
Makefile
|
|
@ -11,7 +11,7 @@ CFLAGS = -Wall
|
|||
ifdef DEBUG
|
||||
CFLAGS += -g
|
||||
else
|
||||
CFLAGS += -O3 -fomit-frame-pointer $(SITE_CFLAGS)
|
||||
CFLAGS += -O3 $(SITE_CFLAGS)
|
||||
endif
|
||||
|
||||
ifdef CONFIG
|
||||
|
|
|
|||
|
|
@ -270,6 +270,7 @@ H{ } clone update-map set
|
|||
{ "innermost-frame-quot" "kernel.private" }
|
||||
{ "innermost-frame-scan" "kernel.private" }
|
||||
{ "set-innermost-frame-quot" "kernel.private" }
|
||||
{ "call-clear" "kernel" }
|
||||
}
|
||||
dup length [ >r first2 r> make-primitive ] 2each
|
||||
|
||||
|
|
|
|||
|
|
@ -29,6 +29,13 @@ IN: bootstrap.stage2
|
|||
wince? [ "windows.ce" require ] when
|
||||
winnt? [ "windows.nt" require ] when
|
||||
|
||||
"deploy-vocab" get [
|
||||
"stage2: deployment mode" print
|
||||
] [
|
||||
"listener" require
|
||||
"none" require
|
||||
] if
|
||||
|
||||
[
|
||||
! Compile everything if compiler is loaded
|
||||
all-words [ changed-word ] each
|
||||
|
|
@ -54,11 +61,8 @@ IN: bootstrap.stage2
|
|||
f error-continuation set-global
|
||||
|
||||
"deploy-vocab" get [
|
||||
"tools.deploy" run
|
||||
"tools.deploy.shaker" run
|
||||
] [
|
||||
"listener" require
|
||||
"none" require
|
||||
|
||||
[
|
||||
boot
|
||||
do-init-hooks
|
||||
|
|
|
|||
|
|
@ -187,3 +187,30 @@ SYMBOL: template-chosen
|
|||
! This should not fail
|
||||
[ ] [ [ end-basic-block ] { } make drop ] unit-test
|
||||
] with-scope
|
||||
|
||||
! Regression
|
||||
SYMBOL: templates-chosen
|
||||
|
||||
V{ } clone templates-chosen set
|
||||
|
||||
: template-choice-1 ;
|
||||
|
||||
\ template-choice-1
|
||||
[ "template-choice-1" templates-chosen get push ]
|
||||
H{
|
||||
{ +input+ { { f "obj" } { [ ] "n" } } }
|
||||
{ +output+ { "obj" } }
|
||||
} define-intrinsic
|
||||
|
||||
: template-choice-2 ;
|
||||
|
||||
\ template-choice-2
|
||||
[ "template-choice-2" templates-chosen get push drop ]
|
||||
{ { f "x" } { f "y" } } define-if-intrinsic
|
||||
|
||||
[ ] [
|
||||
[ 2 template-choice-1 template-choice-2 ] compile-quot drop
|
||||
] unit-test
|
||||
|
||||
[ V{ "template-choice-1" "template-choice-2" } ]
|
||||
[ templates-chosen get ] unit-test
|
||||
|
|
|
|||
|
|
@ -89,7 +89,7 @@ C: <continuation> continuation
|
|||
set-catchstack
|
||||
set-namestack
|
||||
set-retainstack
|
||||
>r set-datastack drop 4 getenv f r>
|
||||
>r set-datastack drop 4 getenv f 4 setenv f r>
|
||||
set-callstack ;
|
||||
|
||||
PRIVATE>
|
||||
|
|
@ -197,3 +197,4 @@ GENERIC: (step-into) ( obj -- )
|
|||
|
||||
M: wrapper (step-into) wrapped break ;
|
||||
M: object (step-into) break ;
|
||||
M: callable (step-into) \ break add* break ;
|
||||
|
|
|
|||
|
|
@ -13,6 +13,5 @@ IN: bootstrap.x86
|
|||
: scan-reg EBX ;
|
||||
: xt-reg ECX ;
|
||||
: fixnum>slot@ arg0 1 SAR ;
|
||||
: next-frame@ -44 ;
|
||||
|
||||
"resource:core/cpu/x86/bootstrap.factor" run-file
|
||||
|
|
|
|||
|
|
@ -13,6 +13,5 @@ IN: bootstrap.x86
|
|||
: scan-reg RBX ;
|
||||
: xt-reg RCX ;
|
||||
: fixnum>slot@ ;
|
||||
: next-frame@ -88 ;
|
||||
|
||||
"resource:core/cpu/x86/bootstrap.factor" run-file
|
||||
|
|
|
|||
|
|
@ -66,6 +66,7 @@ M: x86-backend %prepare-alien-invoke
|
|||
#! all roots.
|
||||
"stack_chain" f temp-reg v>operand %alien-global
|
||||
temp-reg v>operand [] stack-reg MOV
|
||||
temp-reg v>operand [] cell SUB
|
||||
temp-reg v>operand 2 cells [+] ds-reg MOV
|
||||
temp-reg v>operand 3 cells [+] rs-reg MOV ;
|
||||
|
||||
|
|
|
|||
|
|
@ -8,10 +8,10 @@ big-endian off
|
|||
|
||||
1 jit-code-format set
|
||||
|
||||
: scan-save stack-reg 3 bootstrap-cells [+] ;
|
||||
|
||||
: stack-frame-size 8 bootstrap-cells ;
|
||||
|
||||
: scan-save stack-reg 3 bootstrap-cells [+] ;
|
||||
|
||||
[
|
||||
arg0 arg0 quot-array@ [+] MOV ! load array
|
||||
scan-reg arg0 scan@ [+] LEA ! initialize scan pointer
|
||||
|
|
@ -79,9 +79,9 @@ big-endian off
|
|||
|
||||
[
|
||||
load-branch
|
||||
stack-reg [] scan-reg MOV ! save scan pointer
|
||||
scan-save scan-reg MOV ! save scan pointer
|
||||
xt-reg CALL ! call quotation
|
||||
scan-reg stack-reg [] MOV ! restore scan pointer
|
||||
scan-reg scan-save MOV ! restore scan pointer
|
||||
] { } make jit-if-call set
|
||||
|
||||
[
|
||||
|
|
|
|||
|
|
@ -586,7 +586,7 @@ IN: cpu.x86.intrinsics
|
|||
"value" operand [ swap MOV ] %alien-accessor
|
||||
] H{
|
||||
{ +input+ {
|
||||
{ unboxed-c-ptr "value" c-ptr }
|
||||
{ unboxed-c-ptr "value" pinned-c-ptr }
|
||||
{ unboxed-c-ptr "alien" c-ptr }
|
||||
{ f "offset" fixnum }
|
||||
} }
|
||||
|
|
|
|||
|
|
@ -458,8 +458,23 @@ M: loc lazy-store
|
|||
dup loc? over cached? or [ 2drop ] [ %move ] if
|
||||
] each-loc ;
|
||||
|
||||
: reset-phantom ( phantom -- )
|
||||
#! Kill register assignments but preserve constants and
|
||||
#! class information.
|
||||
dup phantom-locs*
|
||||
over [
|
||||
dup constant? [ nip ] [
|
||||
operand-class over set-operand-class
|
||||
] if
|
||||
] 2map
|
||||
over delete-all
|
||||
swap push-all ;
|
||||
|
||||
: reset-phantoms ( -- )
|
||||
[ reset-phantom ] each-phantom ;
|
||||
|
||||
: finalize-contents ( -- )
|
||||
finalize-locs finalize-vregs [ delete-all ] each-phantom ;
|
||||
finalize-locs finalize-vregs reset-phantoms ;
|
||||
|
||||
: %gc ( -- )
|
||||
0 frame-required
|
||||
|
|
@ -468,8 +483,8 @@ M: loc lazy-store
|
|||
|
||||
! Loading stacks to vregs
|
||||
: free-vregs? ( int# float# -- ? )
|
||||
T{ float-regs f 8 } free-vregs length <
|
||||
>r T{ int-regs } free-vregs length < r> and ;
|
||||
T{ float-regs f 8 } free-vregs length <=
|
||||
>r T{ int-regs } free-vregs length <= r> and ;
|
||||
|
||||
: phantom&spec ( phantom spec -- phantom' spec' )
|
||||
[ length f pad-left ] keep
|
||||
|
|
@ -585,24 +600,18 @@ M: loc lazy-store
|
|||
2dup first value-matches?
|
||||
>r >r operand-class 2 r> ?nth class-matches? r> and ;
|
||||
|
||||
: template-specs-match? ( -- ? )
|
||||
phantom-d get +input+ get
|
||||
[ spec-matches? ] phantom&spec-agree? ;
|
||||
|
||||
: template-matches? ( spec -- ? )
|
||||
clone [
|
||||
template-specs-match?
|
||||
[ guess-template-vregs free-vregs? ] [ f ] if
|
||||
] bind ;
|
||||
|
||||
: (find-template) ( templates -- pair/f )
|
||||
[ second template-matches? ] find nip ;
|
||||
phantom-d get +input+ rot at
|
||||
[ spec-matches? ] phantom&spec-agree? ;
|
||||
|
||||
: ensure-template-vregs ( -- )
|
||||
guess-template-vregs free-vregs? [
|
||||
finalize-contents compute-free-vregs
|
||||
] unless ;
|
||||
|
||||
: clear-phantoms ( -- )
|
||||
[ delete-all ] each-phantom ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: set-operand-classes ( classes -- )
|
||||
|
|
@ -614,15 +623,11 @@ PRIVATE>
|
|||
#! Commit all deferred stacking shuffling, and ensure the
|
||||
#! in-memory data and retain stacks are up to date with
|
||||
#! respect to the compiler's current picture.
|
||||
finalize-contents finalize-heights
|
||||
finalize-contents
|
||||
clear-phantoms
|
||||
finalize-heights
|
||||
fresh-objects get dup empty? swap delete-all [ %gc ] unless ;
|
||||
|
||||
: do-template ( pair -- )
|
||||
#! Use with return value from find-template
|
||||
first2
|
||||
clone [ template-inputs call template-outputs ] bind
|
||||
compute-free-vregs ; inline
|
||||
|
||||
: with-template ( quot hash -- )
|
||||
clone [
|
||||
ensure-template-vregs
|
||||
|
|
@ -630,6 +635,10 @@ PRIVATE>
|
|||
] bind
|
||||
compute-free-vregs ; inline
|
||||
|
||||
: do-template ( pair -- )
|
||||
#! Use with return value from find-template
|
||||
first2 with-template ;
|
||||
|
||||
: fresh-object ( obj -- ) fresh-objects get push ;
|
||||
|
||||
: fresh-object? ( obj -- ? ) fresh-objects get memq? ;
|
||||
|
|
@ -651,10 +660,7 @@ PRIVATE>
|
|||
|
||||
: find-template ( templates -- pair/f )
|
||||
#! Pair has shape { quot hash }
|
||||
compute-free-vregs
|
||||
dup (find-template) [ ] [
|
||||
finalize-contents (find-template)
|
||||
] ?if ;
|
||||
[ second template-matches? ] find nip ;
|
||||
|
||||
: operand-tag ( operand -- tag/f )
|
||||
operand-class class-tag ;
|
||||
|
|
|
|||
|
|
@ -338,6 +338,11 @@ $nl
|
|||
{ $code "2 [ 2 + 3 * ] call" "2 2 + 3 *" }
|
||||
} ;
|
||||
|
||||
HELP: call-clear ( quot -- )
|
||||
{ $values { "quot" callable } }
|
||||
{ $description "Calls a quotation with an empty call stack. If the quotation returns, Factor will exit.." }
|
||||
{ $notes "Used to implement " { $link "threads" } "." } ;
|
||||
|
||||
HELP: slip
|
||||
{ $values { "quot" quotation } { "x" object } }
|
||||
{ $description "Calls a quotation while hiding the top of the stack." } ;
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
USING: arrays byte-arrays kernel kernel.private math memory
|
||||
namespaces sequences tools.test math.private quotations
|
||||
continuations prettyprint io.streams.string ;
|
||||
continuations prettyprint io.streams.string debugger ;
|
||||
IN: temporary
|
||||
|
||||
[ 0 ] [ f size ] unit-test
|
||||
|
|
@ -15,19 +15,36 @@ IN: temporary
|
|||
[ { "kernel-error" 11 f f } ]
|
||||
[ [ clear drop ] catch ] unit-test
|
||||
|
||||
[ ] [ :c ] unit-test
|
||||
|
||||
[ { "kernel-error" 13 f f } ]
|
||||
[ [ { } set-retainstack r> ] catch ] unit-test
|
||||
|
||||
[ ] [ :c ] unit-test
|
||||
|
||||
: overflow-d 3 overflow-d ;
|
||||
|
||||
[ { "kernel-error" 12 f f } ]
|
||||
[ [ overflow-d ] catch ] unit-test
|
||||
|
||||
[ ] [ :c ] unit-test
|
||||
|
||||
: (overflow-d-alt) 3 ;
|
||||
|
||||
: overflow-d-alt (overflow-d-alt) overflow-d-alt ;
|
||||
|
||||
[ { "kernel-error" 12 f f } ]
|
||||
[ [ overflow-d-alt ] catch ] unit-test
|
||||
|
||||
[ ] [ [ :c ] string-out drop ] unit-test
|
||||
|
||||
: overflow-r 3 >r overflow-r ;
|
||||
|
||||
[ { "kernel-error" 14 f f } ]
|
||||
[ [ overflow-r ] catch ] unit-test
|
||||
|
||||
[ ] [ :c ] unit-test
|
||||
|
||||
! : overflow-c overflow-c 3 ;
|
||||
!
|
||||
! [ { "kernel-error" 16 f f } ]
|
||||
|
|
@ -45,9 +62,17 @@ IN: temporary
|
|||
[ 6 ] [ f 6 or ] unit-test
|
||||
|
||||
[ slip ] unit-test-fails
|
||||
[ ] [ :c ] unit-test
|
||||
|
||||
[ 1 slip ] unit-test-fails
|
||||
[ ] [ :c ] unit-test
|
||||
|
||||
[ 1 2 slip ] unit-test-fails
|
||||
[ ] [ :c ] unit-test
|
||||
|
||||
[ 1 2 3 slip ] unit-test-fails
|
||||
[ ] [ :c ] unit-test
|
||||
|
||||
|
||||
[ 5 ] [ [ 2 2 + ] 1 slip + ] unit-test
|
||||
|
||||
|
|
@ -76,3 +101,4 @@ IN: temporary
|
|||
[ ] [ callstack set-callstack ] unit-test
|
||||
|
||||
[ 3drop datastack ] unit-test-fails
|
||||
[ ] [ :c ] unit-test
|
||||
|
|
|
|||
|
|
@ -72,3 +72,5 @@ IN: temporary
|
|||
|
||||
[ 3 ] [ 5 7 mod-inv ] unit-test
|
||||
[ 78572682077 ] [ 234829342 342389423843 mod-inv ] unit-test
|
||||
|
||||
[ 2 10 mod-inv ] unit-test-fails
|
||||
|
|
|
|||
|
|
@ -50,7 +50,7 @@ M: integer (^)
|
|||
tuck gcd 1 = [
|
||||
dup 0 < [ + ] [ nip ] if
|
||||
] [
|
||||
[ "Non-trivial divisor found" throw ] unless
|
||||
"Non-trivial divisor found" throw
|
||||
] if ; foldable
|
||||
|
||||
: ^mod ( x y n -- z )
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
USING: kernel math namespaces sequences sbufs strings
|
||||
tools.test ;
|
||||
tools.test classes ;
|
||||
IN: temporary
|
||||
|
||||
[ 5 ] [ "Hello" >sbuf length ] unit-test
|
||||
|
|
@ -18,3 +18,7 @@ IN: temporary
|
|||
] unit-test
|
||||
|
||||
[ SBUF" x" ] [ 1 <sbuf> CHAR: x >bignum over push ] unit-test
|
||||
|
||||
[ fixnum ] [ 1 >bignum SBUF" " new length class ] unit-test
|
||||
|
||||
[ fixnum ] [ 1 >bignum [ ] SBUF" " map-as length class ] unit-test
|
||||
|
|
|
|||
|
|
@ -9,7 +9,7 @@ IN: sbufs
|
|||
M: sbuf set-nth-unsafe
|
||||
underlying >r >r >fixnum r> >fixnum r> set-char-slot ;
|
||||
|
||||
M: sbuf new drop [ 0 <string> ] keep string>sbuf ;
|
||||
M: sbuf new drop [ 0 <string> ] keep >fixnum string>sbuf ;
|
||||
|
||||
: >sbuf ( seq -- sbuf ) SBUF" " clone-like ; inline
|
||||
|
||||
|
|
|
|||
|
|
@ -51,7 +51,7 @@ PRIVATE>
|
|||
>r schedule-thread r> [
|
||||
V{ } set-catchstack
|
||||
{ } set-retainstack
|
||||
[ print-error ] recover stop
|
||||
[ [ print-error ] recover stop ] call-clear
|
||||
] (throw)
|
||||
] curry callcc0 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
USING: arrays kernel kernel.private math namespaces
|
||||
sequences sequences.private strings tools.test vectors
|
||||
continuations random growable ;
|
||||
continuations random growable classes ;
|
||||
IN: temporary
|
||||
|
||||
[ ] [ 10 [ [ -1000000 <vector> ] catch drop ] times ] unit-test
|
||||
|
|
@ -93,3 +93,7 @@ IN: temporary
|
|||
[ t ] [
|
||||
100 >array dup >vector <reversed> >array >r reverse r> =
|
||||
] unit-test
|
||||
|
||||
[ fixnum ] [ 1 >bignum V{ } new length class ] unit-test
|
||||
|
||||
[ fixnum ] [ 1 >bignum [ ] V{ } map-as length class ] unit-test
|
||||
|
|
|
|||
|
|
@ -14,7 +14,7 @@ M: vector like
|
|||
dup array? [ dup length array>vector ] [ >vector ] if
|
||||
] unless ;
|
||||
|
||||
M: vector new drop [ f <array> ] keep array>vector ;
|
||||
M: vector new drop [ f <array> ] keep >fixnum array>vector ;
|
||||
|
||||
M: vector equal?
|
||||
over vector? [ sequence= ] [ 2drop f ] if ;
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
USING: asn1 asn1.ldap io.streams.string tools.test ;
|
||||
USING: asn1 asn1.ldap io io.streams.string tools.test ;
|
||||
|
||||
[ 6 ] [
|
||||
"\u0002\u0001\u0006" <string-reader> [ asn-syntax read-ber ] with-stream
|
||||
|
|
|
|||
|
|
@ -57,10 +57,7 @@ IN: bunny
|
|||
] unless ;
|
||||
|
||||
: draw-triangle ( ns vs triple -- )
|
||||
[
|
||||
dup roll nth first3 glNormal3d
|
||||
swap nth first3 glVertex3d
|
||||
] each-with2 ;
|
||||
[ dup roll nth gl-normal swap nth gl-vertex ] each-with2 ;
|
||||
|
||||
: draw-bunny ( ns vs is -- )
|
||||
GL_TRIANGLES [ [ draw-triangle ] each-with2 ] do-state ;
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
USING: tools.deploy ;
|
||||
USING: tools.deploy.config ;
|
||||
V{
|
||||
{ strip-word-props? t }
|
||||
{ strip-word-names? t }
|
||||
|
|
|
|||
|
|
@ -6,12 +6,13 @@ IN: cfdg.models.aqua-star
|
|||
|
||||
: tentacle ( -- )
|
||||
iterate? [
|
||||
{ [ circle
|
||||
[ .23 y .99 s .002 b tentacle ] do ]
|
||||
[ circle
|
||||
[ .17 y 2 r .99 s .002 b tentacle ] do ]
|
||||
[ circle
|
||||
[ .12 y -2 r .99 s .001 b tentacle ] do ] } random call
|
||||
{ { 1 [ circle
|
||||
[ .23 y .99 s .002 b tentacle ] do ] }
|
||||
{ 1 [ circle
|
||||
[ .17 y 2 r .99 s .002 b tentacle ] do ] }
|
||||
{ 1 [ circle
|
||||
[ .12 y -2 r .99 s .001 b tentacle ] do ] } }
|
||||
call-random-weighted
|
||||
] when ;
|
||||
|
||||
: anemone ( -- )
|
||||
|
|
|
|||
|
|
@ -1,5 +1,4 @@
|
|||
|
||||
|
||||
USING: kernel namespaces math opengl.gl opengl.glu ui ui.gadgets.slate
|
||||
mortar random-weighted cfdg ;
|
||||
|
||||
|
|
@ -24,17 +23,17 @@ IN: cfdg.models.game1-turn6
|
|||
DEFER: start
|
||||
|
||||
: spiral ( -- ) iterate? [
|
||||
{ { 1 [ f-squares
|
||||
[ 0.5 x 0.5 y 45 r f-triangles ] do
|
||||
[ 1 y 25 r 0.9 s spiral ] do ] }
|
||||
{ 0.022 [ [ 90 flip 50 hue start ] do ] } }
|
||||
random-weighted* call
|
||||
{ { 1 [ f-squares
|
||||
[ 0.5 x 0.5 y 45 r f-triangles ] do
|
||||
[ 1 y 25 r 0.9 s spiral ] do ] }
|
||||
{ 0.022 [ [ 90 flip 50 hue start ] do ] } }
|
||||
call-random-weighted
|
||||
] when ;
|
||||
|
||||
: start ( -- )
|
||||
[ spiral ] do
|
||||
[ 120 r spiral ] do
|
||||
[ 240 r spiral ] do ;
|
||||
[ spiral ] do
|
||||
[ 120 r spiral ] do
|
||||
[ 240 r spiral ] do ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
|
|
|
|||
|
|
@ -11,8 +11,8 @@ iterate? [
|
|||
{ 0.03 [ square
|
||||
[ 60 r spike ] do
|
||||
[ -60 r spike ] do
|
||||
[ 0.95 y 0.97 s spike ] do ] }
|
||||
} random-weighted* call
|
||||
[ 0.95 y 0.97 s spike ] do ] } }
|
||||
call-random-weighted
|
||||
] when ;
|
||||
|
||||
: snowflake ( -- )
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
!
|
||||
USING: kernel tools.test math channels channels.private
|
||||
sequences threads ;
|
||||
sequences threads sorting ;
|
||||
IN: temporary
|
||||
|
||||
{ 3 t } [
|
||||
|
|
|
|||
|
|
@ -1,7 +1,8 @@
|
|||
! Copyright (C) 2005 Chris Double. All Rights Reserved.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
!
|
||||
USING: kernel tools.test math assocs channels channels.remote ;
|
||||
USING: kernel tools.test math assocs channels channels.remote
|
||||
channels.remote.private ;
|
||||
IN: temporary
|
||||
|
||||
{ t } [
|
||||
|
|
|
|||
|
|
@ -3,7 +3,8 @@
|
|||
USING: alien alien.c-types alien.compiler
|
||||
arrays assocs combinators compiler inference.transforms kernel
|
||||
math namespaces parser prettyprint prettyprint.sections
|
||||
quotations sequences strings words cocoa.runtime io macros ;
|
||||
quotations sequences strings words cocoa.runtime io macros
|
||||
memoize ;
|
||||
IN: cocoa.messages
|
||||
|
||||
: make-sender ( method function -- quot )
|
||||
|
|
@ -20,10 +21,8 @@ IN: cocoa.messages
|
|||
SYMBOL: message-senders
|
||||
SYMBOL: super-message-senders
|
||||
|
||||
global [
|
||||
message-senders [ H{ } assoc-like ] change
|
||||
super-message-senders [ H{ } assoc-like ] change
|
||||
] bind
|
||||
message-senders global [ H{ } assoc-like ] change-at
|
||||
super-message-senders global [ H{ } assoc-like ] change-at
|
||||
|
||||
: cache-stub ( method function hash -- )
|
||||
[
|
||||
|
|
@ -44,7 +43,7 @@ global [
|
|||
|
||||
TUPLE: selector name object ;
|
||||
|
||||
: <selector> ( name -- sel ) f \ selector construct-boa ;
|
||||
MEMO: <selector> ( name -- sel ) f \ selector construct-boa ;
|
||||
|
||||
: selector ( selector -- alien )
|
||||
dup selector-object expired? [
|
||||
|
|
@ -54,16 +53,9 @@ TUPLE: selector name object ;
|
|||
selector-object
|
||||
] if ;
|
||||
|
||||
SYMBOL: selectors
|
||||
|
||||
H{ } clone selectors set-global
|
||||
|
||||
: cache-selector ( string -- selector )
|
||||
selectors get-global [ <selector> ] cache ;
|
||||
|
||||
SYMBOL: objc-methods
|
||||
|
||||
H{ } clone objc-methods set-global
|
||||
objc-methods global [ H{ } assoc-like ] change-at
|
||||
|
||||
: lookup-method ( selector -- method )
|
||||
dup objc-methods get at
|
||||
|
|
@ -74,19 +66,18 @@ H{ } clone objc-methods set-global
|
|||
\ >r <repetition> >quotation -rot
|
||||
\ r> <repetition> >quotation 3append ;
|
||||
|
||||
: make-prepare-send ( selector method super? -- quot )
|
||||
MEMO: make-prepare-send ( selector method super? -- quot )
|
||||
[
|
||||
[ \ <super> , ] when
|
||||
swap cache-selector , \ selector ,
|
||||
swap <selector> , \ selector ,
|
||||
] [ ] make
|
||||
swap second length 2 - make-dip ;
|
||||
|
||||
MACRO: (send) ( selector super? -- quot )
|
||||
[
|
||||
>r dup lookup-method r>
|
||||
[ make-prepare-send % ] 2keep
|
||||
super-message-senders message-senders ? get at ,
|
||||
] [ ] make ;
|
||||
>r dup lookup-method r>
|
||||
[ make-prepare-send ] 2keep
|
||||
super-message-senders message-senders ? get at
|
||||
[ slip execute ] 2curry ;
|
||||
|
||||
: send ( args... receiver selector -- return... ) f (send) ; inline
|
||||
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
USING: tools.deploy ;
|
||||
USING: tools.deploy.config ;
|
||||
V{
|
||||
{ strip-word-props? t }
|
||||
{ strip-word-names? t }
|
||||
|
|
|
|||
|
|
@ -28,6 +28,10 @@ IN: combinators.lib
|
|||
: tetra ( obj quot quot quot quot -- val val val val )
|
||||
>r >r pick >r bi r> r> r> bi ; inline
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: 2bi ( obj obj quot quot -- val val ) >r 2keep r> call ; inline
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
! The spread family
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@
|
|||
!
|
||||
USING: kernel concurrency threads vectors arrays sequences
|
||||
namespaces tools.test continuations dlists strings math words
|
||||
match quotations ;
|
||||
match quotations concurrency.private ;
|
||||
IN: temporary
|
||||
|
||||
[ V{ 1 2 3 } ] [
|
||||
|
|
|
|||
|
|
@ -1,29 +1,24 @@
|
|||
! Copyright (C) 2007 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: memory io io.files io.styles io.launcher
|
||||
sequences prettyprint kernel arrays xml xml.utilities system
|
||||
hashtables sorting math.parser assocs ;
|
||||
USING: io.files io.launcher io.styles io hashtables kernel
|
||||
sequences combinators.lib assocs system sorting math.parser ;
|
||||
IN: contributors
|
||||
|
||||
: changelog ( -- xml )
|
||||
: changelog ( -- authors )
|
||||
image parent-dir cd
|
||||
"darcs changes --xml-output" <process-stream> read-xml ;
|
||||
|
||||
: authors ( xml -- seq )
|
||||
children-tags [ "author" swap at ] map ;
|
||||
|
||||
: patch-count ( authors author -- n )
|
||||
[ = ] curry subset length ;
|
||||
"git-log --pretty=format:%an" <process-stream> lines ;
|
||||
|
||||
: patch-counts ( authors -- assoc )
|
||||
dup prune [ [ patch-count ] keep 2array ] curry* map ;
|
||||
dup prune
|
||||
[ dup rot [ = ] curry* count ] curry*
|
||||
{ } map>assoc ;
|
||||
|
||||
: contributors ( -- )
|
||||
changelog authors patch-counts sort-keys <reversed>
|
||||
changelog patch-counts sort-values <reversed>
|
||||
standard-table-style [
|
||||
[
|
||||
[
|
||||
first2
|
||||
first2 swap
|
||||
[ write ] with-cell
|
||||
[ number>string write ] with-cell
|
||||
] with-row
|
||||
|
|
|
|||
|
|
@ -40,5 +40,5 @@ TUPLE: coroutine resumecc exitcc ;
|
|||
|
||||
: coterminate ( v -- )
|
||||
current-coro get
|
||||
f over set-coroutine-resumecc
|
||||
[ ] over set-coroutine-resumecc
|
||||
coroutine-exitcc continue-with ;
|
||||
|
|
|
|||
|
|
@ -1,23 +1,24 @@
|
|||
USING: kernel math sequences namespaces math-contrib ;
|
||||
IN: crypto-internals
|
||||
USING: kernel math sequences namespaces ;
|
||||
IN: crypto.rc4
|
||||
|
||||
! http://en.wikipedia.org/wiki/RC4_%28cipher%29
|
||||
|
||||
<PRIVATE
|
||||
|
||||
SYMBOL: i
|
||||
SYMBOL: j
|
||||
SYMBOL: s
|
||||
SYMBOL: key
|
||||
SYMBOL: l
|
||||
|
||||
|
||||
! key scheduling algorithm, initialize s
|
||||
: ksa ( -- )
|
||||
256 [ ] map s set
|
||||
0 j set
|
||||
256 [
|
||||
dup s get nth j get + over l get mod key get nth + 255 bitand j set
|
||||
dup j get s get exchange
|
||||
] repeat ;
|
||||
dup j get s get exchange drop
|
||||
] each ;
|
||||
|
||||
: generate ( -- n )
|
||||
i get 1+ 255 bitand i set
|
||||
|
|
@ -25,12 +26,14 @@ SYMBOL: l
|
|||
i get j get s get exchange
|
||||
i get s get nth j get s get nth + 255 bitand s get nth ;
|
||||
|
||||
IN: crypto
|
||||
PRIVATE>
|
||||
|
||||
: rc4 ( key -- )
|
||||
[ key set ] keep
|
||||
length l set
|
||||
ksa
|
||||
0 i set
|
||||
0 j set ;
|
||||
[
|
||||
[ key set ] keep
|
||||
length l set
|
||||
ksa
|
||||
0 i set
|
||||
0 j set
|
||||
] with-scope ;
|
||||
|
||||
|
|
@ -1,26 +0,0 @@
|
|||
USING: kernel math namespaces math-contrib errors ;
|
||||
|
||||
IN: crypto
|
||||
SYMBOL: d
|
||||
SYMBOL: p
|
||||
SYMBOL: q
|
||||
SYMBOL: n
|
||||
SYMBOL: m
|
||||
SYMBOL: ee
|
||||
|
||||
! e = public key, d = private key, n = public modulus
|
||||
TUPLE: rsa e d n ;
|
||||
|
||||
! n bits
|
||||
: generate-rsa-keypair ( bitlen -- <rsa> )
|
||||
[
|
||||
2 /i generate-two-unique-primes [ q set p set ] 2keep [ * n set ] 2keep
|
||||
[ 1- ] 2apply * m set
|
||||
65537 ee set
|
||||
m get ee get mod-inv m get + d set
|
||||
ee get d get n get <rsa>
|
||||
] with-scope ;
|
||||
|
||||
: rsa-encrypt ( message rsa -- encrypted ) [ rsa-e ] keep rsa-n ^mod ;
|
||||
: rsa-decrypt ( encrypted rsa -- message ) [ rsa-d ] keep rsa-n ^mod ;
|
||||
|
||||
|
|
@ -3,5 +3,5 @@ USING: kernel math namespaces crypto.rsa tools.test ;
|
|||
[ 123456789 ] [ 128 generate-rsa-keypair 123456789 over rsa-encrypt swap rsa-decrypt ] unit-test
|
||||
[ 123456789 ] [ 129 generate-rsa-keypair 123456789 over rsa-encrypt swap rsa-decrypt ] unit-test
|
||||
[ 123456789 ] [ 130 generate-rsa-keypair 123456789 over rsa-encrypt swap rsa-decrypt ] unit-test
|
||||
[ 123 ] [ 17 2753 3233 <rsa> 123 over rsa-encrypt swap rsa-decrypt ] unit-test
|
||||
[ 123 ] [ 3233 2753 17 <rsa> 123 over rsa-encrypt swap rsa-decrypt ] unit-test
|
||||
|
||||
|
|
|
|||
|
|
@ -2,28 +2,44 @@ USING: math.miller-rabin kernel math math.functions namespaces
|
|||
sequences ;
|
||||
IN: crypto.rsa
|
||||
|
||||
SYMBOL: d
|
||||
SYMBOL: p
|
||||
SYMBOL: q
|
||||
SYMBOL: n
|
||||
SYMBOL: m
|
||||
SYMBOL: ee
|
||||
! The private key is the only secret.
|
||||
|
||||
! e = public key, d = private key, n = public modulus
|
||||
TUPLE: rsa e d n ;
|
||||
! p,q are two random primes of numbits/2
|
||||
! phi = (p-1)(q-1)
|
||||
! modulus = p*q
|
||||
! public = 65537
|
||||
! private = public modinv phi
|
||||
|
||||
TUPLE: rsa modulus private-key public-key ;
|
||||
|
||||
C: <rsa> rsa
|
||||
|
||||
! n bits
|
||||
<PRIVATE
|
||||
|
||||
: public-key 65537 ; inline
|
||||
|
||||
: rsa-primes ( numbits -- p q )
|
||||
2/ 2 unique-primes first2 ;
|
||||
|
||||
: modulus-phi ( numbits -- n phi )
|
||||
#! Loop until phi is not divisible by the public key.
|
||||
dup rsa-primes [ * ] 2keep
|
||||
[ 1- ] 2apply *
|
||||
dup public-key gcd nip 1 = [
|
||||
rot drop
|
||||
] [
|
||||
2drop modulus-phi
|
||||
] if ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: generate-rsa-keypair ( numbits -- <rsa> )
|
||||
[
|
||||
2 /i 2 unique-primes first2 [ q set p set ] 2keep [ * n set ] 2keep
|
||||
[ 1- ] 2apply * m set
|
||||
65537 ee set
|
||||
m get ee get mod-inv m get + d set
|
||||
ee get d get n get <rsa>
|
||||
] with-scope ;
|
||||
modulus-phi
|
||||
public-key over mod-inv +
|
||||
public-key <rsa> ;
|
||||
|
||||
: rsa-encrypt ( message rsa -- encrypted ) [ rsa-e ] keep rsa-n ^mod ;
|
||||
: rsa-decrypt ( encrypted rsa -- message ) [ rsa-d ] keep rsa-n ^mod ;
|
||||
: rsa-encrypt ( message rsa -- encrypted )
|
||||
[ rsa-public-key ] keep rsa-modulus ^mod ;
|
||||
|
||||
: rsa-decrypt ( encrypted rsa -- message )
|
||||
[ rsa-private-key ] keep rsa-modulus ^mod ;
|
||||
|
|
@ -1,7 +0,0 @@
|
|||
USING: kernel math test namespaces crypto ;
|
||||
|
||||
[ 123456789 ] [ 128 generate-rsa-keypair 123456789 over rsa-encrypt swap rsa-decrypt ] unit-test
|
||||
[ 123456789 ] [ 129 generate-rsa-keypair 123456789 over rsa-encrypt swap rsa-decrypt ] unit-test
|
||||
[ 123456789 ] [ 130 generate-rsa-keypair 123456789 over rsa-encrypt swap rsa-decrypt ] unit-test
|
||||
[ 123 ] [ 17 2753 3233 <rsa> 123 over rsa-encrypt swap rsa-decrypt ] unit-test
|
||||
|
||||
|
|
@ -1,4 +1,4 @@
|
|||
USING: crypto.timing kernel tools.test ;
|
||||
USING: crypto.timing kernel tools.test system math ;
|
||||
IN: temporary
|
||||
|
||||
[ t ] [ millis [ ] 1000 with-timing millis swap - 1000 >= ] unit-test
|
||||
|
|
|
|||
|
|
@ -1,9 +0,0 @@
|
|||
USING: errors kernel math sequences ;
|
||||
IN: crypto
|
||||
|
||||
TUPLE: no-xor-key ;
|
||||
|
||||
: xor-crypt ( key seq -- seq )
|
||||
over empty? [ <no-xor-key> throw ] when
|
||||
[ length ] keep
|
||||
[ >r over mod-nth r> bitxor ] 2map nip ;
|
||||
|
|
@ -1,4 +1,5 @@
|
|||
USING: crypto errors kernel test strings ;
|
||||
USING: continuations crypto.xor kernel strings tools.test ;
|
||||
IN: temporary
|
||||
|
||||
! No key
|
||||
[ T{ no-xor-key f } ] [ [ "" dup xor-crypt ] catch ] unit-test
|
||||
|
|
@ -7,7 +8,7 @@ USING: crypto errors kernel test strings ;
|
|||
[ T{ no-xor-key f } ] [ [ "" "asdf" dupd xor-crypt xor-crypt ] catch ] unit-test
|
||||
|
||||
! a xor a = 0
|
||||
[ { 0 0 0 0 0 0 0 } ] [ "abcdefg" dup xor-crypt ] unit-test
|
||||
[ "\0\0\0\0\0\0\0" ] [ "abcdefg" dup xor-crypt ] unit-test
|
||||
|
||||
[ { 15 15 15 15 } ] [ { 10 10 10 10 } { 5 5 5 5 } xor-crypt ] unit-test
|
||||
|
||||
|
|
@ -0,0 +1,8 @@
|
|||
USING: crypto.common kernel math sequences ;
|
||||
IN: crypto.xor
|
||||
|
||||
TUPLE: no-xor-key ;
|
||||
|
||||
: xor-crypt ( key seq -- seq )
|
||||
over empty? [ no-xor-key construct-empty throw ] when
|
||||
dup length rot [ mod-nth bitxor ] curry 2map ;
|
||||
|
|
@ -1,4 +1,4 @@
|
|||
USING: destructors kernel tools.test ;
|
||||
USING: destructors kernel tools.test continuations ;
|
||||
IN: temporary
|
||||
|
||||
TUPLE: dummy-obj destroyed? ;
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
USING: tools.deploy ;
|
||||
USING: tools.deploy.config ;
|
||||
V{
|
||||
{ strip-globals? f }
|
||||
{ strip-word-props? f }
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
USING: tools.deploy ;
|
||||
USING: tools.deploy.config ;
|
||||
V{
|
||||
{ strip-word-props? t }
|
||||
{ strip-word-names? f }
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
USING: tools.deploy ;
|
||||
USING: tools.deploy.config ;
|
||||
V{
|
||||
{ strip-word-props? t }
|
||||
{ strip-word-names? t }
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
USING: tools.deploy ;
|
||||
USING: tools.deploy.config ;
|
||||
V{
|
||||
{ strip-word-props? t }
|
||||
{ strip-word-names? t }
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
USING: tools.deploy ;
|
||||
USING: tools.deploy.config ;
|
||||
V{
|
||||
{ strip-word-props? t }
|
||||
{ strip-word-names? t }
|
||||
|
|
|
|||
|
|
@ -1,4 +1,5 @@
|
|||
USING: inverse tools.test arrays math kernel sequences ;
|
||||
USING: inverse tools.test arrays math kernel sequences
|
||||
math.functions ;
|
||||
|
||||
[ 2 ] [ { 3 2 } [ 3 swap 2array ] undo ] unit-test
|
||||
[ { 3 4 } [ dup 2array ] undo ] unit-test-fails
|
||||
|
|
|
|||
|
|
@ -1,4 +1,5 @@
|
|||
USING: io io.mmap kernel tools.test ;
|
||||
USING: io io.mmap io.files kernel tools.test continuations
|
||||
sequences ;
|
||||
IN: temporary
|
||||
|
||||
[ "mmap-test-file.txt" resource-path delete-file ] catch drop
|
||||
|
|
|
|||
|
|
@ -5,6 +5,9 @@ windows.errors windows.kernel32 prettyprint strings splitting
|
|||
io.files windows.winsock ;
|
||||
IN: io.windows.nt.backend
|
||||
|
||||
: .. global [ . flush ] bind ;
|
||||
: .S global [ .s flush ] bind ;
|
||||
|
||||
: unicode-prefix ( -- seq )
|
||||
"\\\\?\\" ; inline
|
||||
|
||||
|
|
@ -92,7 +95,7 @@ C: <GetQueuedCompletionStatusParams> GetQueuedCompletionStatusParams
|
|||
|
||||
: lookup-callback ( GetQueuedCompletion-args -- callback )
|
||||
GetQueuedCompletionStatusParams-lpOverlapped* *void*
|
||||
\ io-hash get-global delete-at drop ;
|
||||
\ io-hash get-global delete-at* drop ;
|
||||
|
||||
: wait-for-io ( timeout -- continuation/f )
|
||||
wait-for-overlapped
|
||||
|
|
|
|||
|
|
@ -48,7 +48,7 @@ TUPLE: ConnectEx-args port
|
|||
: check-connect-error ( ConnectEx -- )
|
||||
ConnectEx-args-port duplex-stream-in get-overlapped-result drop ;
|
||||
|
||||
: connect-continuation ( duplex-stream ConnectEx -- )
|
||||
: connect-continuation ( ConnectEx -- )
|
||||
[ ConnectEx-args-port duplex-stream-in save-callback ] keep
|
||||
check-connect-error ;
|
||||
|
||||
|
|
@ -154,7 +154,6 @@ M: windows-nt-io <server> ( addrspec -- server )
|
|||
] keep <server-port>
|
||||
] with-destructors ;
|
||||
|
||||
|
||||
M: windows-nt-io <datagram> ( addrspec -- datagram )
|
||||
[
|
||||
[
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
USING: kernel ;
|
||||
USING: io.files kernel tools.test ;
|
||||
IN: temporary
|
||||
|
||||
[ "c:\\foo\\" ] [ "c:\\foo\\bar" parent-dir ] unit-test
|
||||
|
|
|
|||
|
|
@ -14,7 +14,7 @@ IN: jamshred.gl
|
|||
|
||||
: draw-segment-vertex ( segment theta -- )
|
||||
over segment-color gl-color segment-vertex-and-normal
|
||||
first3 glNormal3d first3 glVertex3d ;
|
||||
gl-normal gl-vertex ;
|
||||
|
||||
: draw-vertex-pair ( theta next-segment segment -- )
|
||||
rot tuck draw-segment-vertex draw-segment-vertex ;
|
||||
|
|
|
|||
|
|
@ -7,7 +7,7 @@ IN: temporary
|
|||
{ { 1 } { 2 3 } { 4 5 6 } { 7 8 } { } } graded
|
||||
] unit-test
|
||||
|
||||
SYMBOLS: x1 x2 x3 x4 z1 z2 ;
|
||||
SYMBOLS: x1 x2 x3 x4 x5 x6 z1 z2 ;
|
||||
|
||||
[ H{ { { x1 } 3 } } ] [ x1 3 wedge ] unit-test
|
||||
|
||||
|
|
@ -23,7 +23,7 @@ x3 x4 wedge z2 d=
|
|||
! Unimodular example
|
||||
boundaries get clear-assoc
|
||||
|
||||
SYMBOLS: x y z ;
|
||||
SYMBOLS: x y w z ;
|
||||
|
||||
x y wedge z d=
|
||||
y z wedge x d=
|
||||
|
|
|
|||
|
|
@ -1,6 +1,7 @@
|
|||
|
||||
USING: kernel math vectors sequences opengl.gl math.vectors math.matrices
|
||||
vars opengl.lib self pos ori turtle lsys.tortoise lsys.strings ;
|
||||
USING: kernel math vectors sequences opengl.gl math.vectors
|
||||
math.matrices vars opengl self pos ori turtle lsys.tortoise
|
||||
lsys.strings ;
|
||||
|
||||
IN: lsys.tortoise.graphics
|
||||
|
||||
|
|
@ -12,7 +13,7 @@ IN: lsys.tortoise.graphics
|
|||
|
||||
: (polygon) ( vertices -- )
|
||||
GL_POLYGON glBegin
|
||||
dup polygon-normal gl-normal-3f [ gl-vertex-3f ] each
|
||||
dup polygon-normal gl-normal [ gl-vertex ] each
|
||||
glEnd ;
|
||||
|
||||
: polygon ( vertices -- ) dup length 3 >= [ (polygon) ] [ drop ] if ;
|
||||
|
|
@ -31,7 +32,7 @@ VAR: vertices
|
|||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: record-vertex ( -- ) pos> gl-vertex-3f ;
|
||||
: record-vertex ( -- ) pos> gl-vertex ;
|
||||
|
||||
: draw-forward ( length -- )
|
||||
GL_LINES glBegin record-vertex step-turtle record-vertex glEnd ;
|
||||
|
|
@ -78,10 +79,10 @@ VAR: color-table
|
|||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: material-color ( color -- )
|
||||
GL_FRONT_AND_BACK GL_AMBIENT_AND_DIFFUSE rot gl-material-fv ;
|
||||
GL_FRONT_AND_BACK GL_AMBIENT_AND_DIFFUSE rot gl-material ;
|
||||
|
||||
: set-color ( i -- )
|
||||
dup >color color-table> nth dup gl-color-4f material-color ;
|
||||
dup >color color-table> nth dup gl-color material-color ;
|
||||
|
||||
: inc-color ( -- ) color> 1+ set-color ;
|
||||
|
||||
|
|
|
|||
|
|
@ -0,0 +1,13 @@
|
|||
USING: tools.deploy ;
|
||||
V{
|
||||
{ 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? t }
|
||||
{ "bundle-name" "Lindenmayer Systems.app" }
|
||||
}
|
||||
|
|
@ -1,5 +1,6 @@
|
|||
|
||||
USING: kernel namespaces threads math math.vectors quotations sequences
|
||||
opengl
|
||||
opengl.gl
|
||||
colors
|
||||
ui
|
||||
|
|
@ -11,7 +12,7 @@ USING: kernel namespaces threads math math.vectors quotations sequences
|
|||
ui.gadgets.lib
|
||||
ui.gadgets.slate
|
||||
ui.gadgets.theme
|
||||
vars rewrite-closures opengl.lib
|
||||
vars rewrite-closures
|
||||
self pos ori turtle opengl.camera
|
||||
lsys.tortoise lsys.tortoise.graphics lsys.strings
|
||||
;
|
||||
|
|
@ -34,7 +35,7 @@ VAR: model
|
|||
|
||||
: display ( -- )
|
||||
|
||||
black gl-clear-color
|
||||
black gl-clear
|
||||
|
||||
GL_FLAT glShadeModel
|
||||
|
||||
|
|
@ -48,13 +49,11 @@ glLoadIdentity
|
|||
|
||||
camera> do-look-at
|
||||
|
||||
GL_COLOR_BUFFER_BIT glClear
|
||||
|
||||
GL_FRONT_AND_BACK GL_LINE glPolygonMode
|
||||
|
||||
white gl-color-4f
|
||||
white gl-color
|
||||
|
||||
GL_LINES glBegin { 0 0 0 } gl-vertex-3f { 0 0 1 } gl-vertex-3f glEnd
|
||||
GL_LINES glBegin { 0 0 0 } gl-vertex { 0 0 1 } gl-vertex glEnd
|
||||
|
||||
color> set-color
|
||||
|
||||
|
|
|
|||
|
|
@ -1,4 +1,5 @@
|
|||
USING: kernel math math.functions tools.test ;
|
||||
USING: kernel math math.functions tools.test math.analysis
|
||||
math.constants ;
|
||||
IN: temporary
|
||||
|
||||
: eps
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
IN: temporary
|
||||
USING: kernel math.matrices math.matrices.elimination
|
||||
tools.test ;
|
||||
tools.test sequences ;
|
||||
|
||||
[
|
||||
{
|
||||
|
|
|
|||
|
|
@ -1,4 +1,5 @@
|
|||
USING: kernel math.numerical-integration ;
|
||||
USING: kernel math.numerical-integration tools.test math
|
||||
math.constants math.functions ;
|
||||
IN: temporary
|
||||
|
||||
[ 50 ] [ 0 10 [ ] integrate-simpson ] unit-test
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
IN: temporary
|
||||
USING: kernel math tools.test ;
|
||||
USING: kernel math math.polynomials tools.test ;
|
||||
|
||||
! Tests
|
||||
[ { 0 1 } ] [ { 0 1 0 0 } ptrim ] unit-test
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
USING: tools.deploy ;
|
||||
USING: tools.deploy.config ;
|
||||
V{
|
||||
{ strip-word-props? t }
|
||||
{ strip-word-names? f }
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
USING: tools.deploy ;
|
||||
USING: tools.deploy.config ;
|
||||
V{
|
||||
{ strip-word-props? t }
|
||||
{ strip-word-names? t }
|
||||
|
|
|
|||
|
|
@ -1 +1,2 @@
|
|||
Slava Pestov
|
||||
Eduardo Cavazos
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
|
||||
USING: kernel namespaces math.vectors opengl.lib pos ori turtle self ;
|
||||
USING: kernel namespaces math.vectors opengl pos ori turtle self ;
|
||||
|
||||
IN: opengl.camera
|
||||
|
||||
|
|
@ -13,4 +13,4 @@ IN: opengl.camera
|
|||
[ 90 pitch-up pos> 1 step-turtle pos> swap v- ] save-self ;
|
||||
|
||||
: do-look-at ( camera -- )
|
||||
[ >self camera-eye camera-focus camera-up glu-look-at ] with-scope ;
|
||||
[ >self camera-eye camera-focus camera-up gl-look-at ] with-scope ;
|
||||
|
|
|
|||
|
|
@ -1,19 +0,0 @@
|
|||
USING: kernel alien.c-types sequences opengl.gl opengl.glu ;
|
||||
|
||||
IN: opengl.lib
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: gl-color-4f ( 4seq -- ) first4 glColor4f ;
|
||||
|
||||
: gl-clear-color ( 4seq -- ) first4 glClearColor ;
|
||||
|
||||
: gl-vertex-3f ( array -- ) first3 glVertex3f ;
|
||||
|
||||
: gl-normal-3f ( array -- ) first3 glNormal3f ;
|
||||
|
||||
: gl-material-fv ( face pname params -- ) >c-float-array glMaterialfv ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: glu-look-at ( eye focus up -- ) >r >r first3 r> first3 r> first3 gluLookAt ;
|
||||
|
|
@ -1,7 +1,8 @@
|
|||
! Copyright (C) 2005, 2006 Slava Pestov.
|
||||
! Copyright (C) 2005, 2007 Slava Pestov.
|
||||
! 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 ;
|
||||
sequences math.vectors opengl.gl opengl.glu combinators ;
|
||||
IN: opengl
|
||||
|
||||
: coordinates [ first2 ] 2apply ;
|
||||
|
|
@ -10,8 +11,11 @@ IN: opengl
|
|||
|
||||
: gl-color ( color -- ) first4 glColor4d ; inline
|
||||
|
||||
: gl-clear-color ( color -- )
|
||||
first4 glClearColor ;
|
||||
|
||||
: gl-clear ( color -- )
|
||||
first4 glClearColor GL_COLOR_BUFFER_BIT glClear ;
|
||||
gl-clear-color GL_COLOR_BUFFER_BIT glClear ;
|
||||
|
||||
: gl-error ( -- )
|
||||
glGetError dup zero? [
|
||||
|
|
@ -28,7 +32,17 @@ IN: opengl
|
|||
swap [ glMatrixMode glPushMatrix call ] keep
|
||||
glMatrixMode glPopMatrix ; inline
|
||||
|
||||
: gl-vertex ( point -- ) first2 glVertex2d ; inline
|
||||
: gl-vertex ( point -- )
|
||||
dup length {
|
||||
{ 2 [ first2 glVertex2d ] }
|
||||
{ 3 [ first3 glVertex3d ] }
|
||||
{ 4 [ first4 glVertex4d ] }
|
||||
} case ;
|
||||
|
||||
: gl-normal ( normal -- ) first3 glNormal3d ;
|
||||
|
||||
: gl-material ( face pname params -- )
|
||||
>c-float-array glMaterialfv ;
|
||||
|
||||
: gl-line ( a b -- )
|
||||
GL_LINES [ gl-vertex gl-vertex ] do-state ;
|
||||
|
|
@ -67,6 +81,9 @@ IN: opengl
|
|||
: do-attribs ( bits quot -- )
|
||||
swap glPushAttrib call glPopAttrib ; inline
|
||||
|
||||
: gl-look-at ( eye focus up -- )
|
||||
>r >r first3 r> first3 r> first3 gluLookAt ;
|
||||
|
||||
TUPLE: sprite loc dim dim2 dlist texture ;
|
||||
|
||||
: <sprite> ( loc dim dim2 -- sprite )
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
USING: kernel sequences.lib ;
|
||||
USING: kernel sequences.lib math math.functions tools.test ;
|
||||
|
||||
[ 4 ] [ { 1 2 } [ sq ] [ * ] map-reduce ] unit-test
|
||||
[ 36 ] [ { 2 3 } [ sq ] [ * ] map-reduce ] unit-test
|
||||
|
|
|
|||
|
|
@ -2,7 +2,8 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
!
|
||||
USING: tools.test kernel serialize io io.streams.string math
|
||||
alien arrays byte-arrays sequences math prettyprint ;
|
||||
alien arrays byte-arrays sequences math prettyprint parser
|
||||
classes math.constants ;
|
||||
IN: temporary
|
||||
|
||||
TUPLE: serialize-test a b ;
|
||||
|
|
|
|||
|
|
@ -0,0 +1,123 @@
|
|||
|
||||
USING: kernel namespaces arrays sequences math math.vectors random
|
||||
springies springies.ui ;
|
||||
|
||||
IN: springies.models.2snake
|
||||
|
||||
: model ( -- )
|
||||
|
||||
{ } clone >nodes
|
||||
{ } clone >springs
|
||||
0.001 >time-slice
|
||||
gravity off
|
||||
|
||||
1 19.0 328.0 0.0 0.0 1.0 1.0 mass
|
||||
2 36.0 328.0 0.0 0.0 1.0 1.0 mass
|
||||
3 54.0 328.0 0.0 0.0 1.0 1.0 mass
|
||||
4 72.0 328.0 0.0 0.0 1.0 1.0 mass
|
||||
5 90.0 328.0 0.0 0.0 1.0 1.0 mass
|
||||
6 108.0 328.0 0.0 0.0 1.0 1.0 mass
|
||||
7 126.0 328.0 0.0 0.0 1.0 1.0 mass
|
||||
8 144.0 328.0 0.0 0.0 1.0 1.0 mass
|
||||
9 162.0 328.0 0.0 0.0 1.0 1.0 mass
|
||||
10 180.0 328.0 0.0 0.0 1.0 1.0 mass
|
||||
11 198.0 328.0 0.0 0.0 1.0 1.0 mass
|
||||
12 216.0 328.0 0.0 0.0 1.0 1.0 mass
|
||||
13 234.0 328.0 0.0 0.0 1.0 1.0 mass
|
||||
14 252.0 328.0 0.0 0.0 1.0 1.0 mass
|
||||
15 270.0 328.0 0.0 0.0 1.0 1.0 mass
|
||||
16 288.0 328.0 0.0 0.0 1.0 1.0 mass
|
||||
17 306.0 328.0 0.0 0.0 1.0 1.0 mass
|
||||
18 324.0 328.0 0.0 0.0 1.0 1.0 mass
|
||||
19 342.0 328.0 0.0 0.0 1.0 1.0 mass
|
||||
20 360.0 328.0 0.0 0.0 1.0 1.0 mass
|
||||
21 378.0 328.0 0.0 0.0 1.0 1.0 mass
|
||||
22 396.0 328.0 0.0 0.0 1.0 1.0 mass
|
||||
23 414.0 328.0 0.0 0.0 1.0 1.0 mass
|
||||
24 432.0 328.0 0.0 0.0 1.0 1.0 mass
|
||||
25 450.0 328.0 0.0 0.0 1.0 1.0 mass
|
||||
26 468.0 328.0 0.0 0.0 1.0 1.0 mass
|
||||
27 504.0 328.0 0.0 0.0 1.0 1.0 mass
|
||||
28 486.0 328.0 0.0 0.0 1.0 1.0 mass
|
||||
29 522.0 328.0 0.0 0.0 1.0 1.0 mass
|
||||
30 540.0 328.0 0.0 0.0 1.0 1.0 mass
|
||||
31 558.0 328.0 0.0 0.0 1.0 1.0 mass
|
||||
32 576.0 328.0 0.0 0.0 1.0 1.0 mass
|
||||
33 594.0 328.0 0.0 0.0 1.0 1.0 mass
|
||||
34 612.0 328.0 0.0 0.0 1.0 1.0 mass
|
||||
35 630.0 328.0 0.0 0.0 1.0 1.0 mass
|
||||
1 1 2 200.0 1.500000 18.0 spng
|
||||
2 3 2 200.0 1.500000 18.0 spng
|
||||
3 3 4 200.0 1.500000 18.0 spng
|
||||
4 4 5 200.0 1.500000 18.0 spng
|
||||
5 5 6 200.0 1.500000 18.0 spng
|
||||
6 6 7 200.0 1.500000 18.0 spng
|
||||
7 7 8 200.0 1.500000 18.0 spng
|
||||
8 8 9 200.0 1.500000 18.0 spng
|
||||
9 9 10 200.0 1.500000 18.0 spng
|
||||
10 10 11 200.0 1.500000 18.0 spng
|
||||
11 11 12 200.0 1.500000 18.0 spng
|
||||
12 12 13 200.0 1.500000 18.0 spng
|
||||
13 13 14 200.0 1.500000 18.0 spng
|
||||
14 14 15 200.0 1.500000 18.0 spng
|
||||
15 15 16 200.0 1.500000 18.0 spng
|
||||
16 16 17 200.0 1.500000 18.0 spng
|
||||
17 17 18 200.0 1.500000 18.0 spng
|
||||
18 18 19 200.0 1.500000 18.0 spng
|
||||
19 19 20 200.0 1.500000 18.0 spng
|
||||
20 20 21 200.0 1.500000 18.0 spng
|
||||
21 21 22 200.0 1.500000 18.0 spng
|
||||
22 22 23 200.0 1.500000 18.0 spng
|
||||
23 23 24 200.0 1.500000 18.0 spng
|
||||
24 24 25 200.0 1.500000 18.0 spng
|
||||
25 25 26 200.0 1.500000 18.0 spng
|
||||
26 26 28 200.0 1.500000 18.0 spng
|
||||
27 28 27 200.0 1.500000 18.0 spng
|
||||
28 27 29 200.0 1.500000 18.0 spng
|
||||
29 29 30 200.0 1.500000 18.0 spng
|
||||
30 30 31 200.0 1.500000 18.0 spng
|
||||
31 31 32 200.0 1.500000 18.0 spng
|
||||
32 32 33 200.0 1.500000 18.0 spng
|
||||
33 33 34 200.0 1.500000 18.0 spng
|
||||
34 34 35 200.0 1.500000 18.0 spng
|
||||
35 1 3 200.0 1.500000 36.0 spng
|
||||
36 2 4 200.0 1.500000 36.0 spng
|
||||
37 3 5 200.0 1.500000 36.0 spng
|
||||
38 4 6 200.0 1.500000 36.0 spng
|
||||
39 5 7 200.0 1.500000 36.0 spng
|
||||
40 6 8 200.0 1.500000 36.0 spng
|
||||
41 7 9 200.0 1.500000 36.0 spng
|
||||
42 8 10 200.0 1.500000 36.0 spng
|
||||
43 9 11 200.0 1.500000 36.0 spng
|
||||
44 10 12 200.0 1.500000 36.0 spng
|
||||
45 11 13 200.0 1.500000 36.0 spng
|
||||
46 12 14 200.0 1.500000 36.0 spng
|
||||
47 13 15 200.0 1.500000 36.0 spng
|
||||
48 14 16 200.0 1.500000 36.0 spng
|
||||
49 15 17 200.0 1.500000 36.0 spng
|
||||
50 16 18 200.0 1.500000 36.0 spng
|
||||
51 17 19 200.0 1.500000 36.0 spng
|
||||
52 18 20 200.0 1.500000 36.0 spng
|
||||
53 19 21 200.0 1.500000 36.0 spng
|
||||
54 20 22 200.0 1.500000 36.0 spng
|
||||
55 21 23 200.0 1.500000 36.0 spng
|
||||
56 22 24 200.0 1.500000 36.0 spng
|
||||
57 23 25 200.0 1.500000 36.0 spng
|
||||
58 24 26 200.0 1.500000 36.0 spng
|
||||
59 25 28 200.0 1.500000 36.0 spng
|
||||
60 26 27 200.0 1.500000 36.0 spng
|
||||
61 28 29 200.0 1.500000 36.0 spng
|
||||
62 27 30 200.0 1.500000 36.0 spng
|
||||
63 29 31 200.0 1.500000 36.0 spng
|
||||
64 30 32 200.0 1.500000 36.0 spng
|
||||
65 31 33 200.0 1.500000 36.0 spng
|
||||
66 32 34 200.0 1.500000 36.0 spng
|
||||
67 33 35 200.0 1.500000 36.0 spng
|
||||
|
||||
nodes> [ 400 random -200 + 400 random -200 + 2array swap set-node-vel ] each ;
|
||||
|
||||
USING: threads ui ;
|
||||
|
||||
: go ( -- ) [ [ springies-window* 1000 sleep model ] with-scope ] with-ui ;
|
||||
|
||||
MAIN: go
|
||||
|
|
@ -0,0 +1,255 @@
|
|||
|
||||
USING: kernel namespaces sequences springies springies.ui ;
|
||||
|
||||
IN: springies.models.ball
|
||||
|
||||
: model ( -- )
|
||||
|
||||
{ } clone >nodes
|
||||
{ } clone >springs
|
||||
0.01 >time-slice
|
||||
gravity on
|
||||
|
||||
1 325.191871 140.872641 40.832215 -5.301529 1.0 1.0 mass
|
||||
2 313.933994 149.011616 55.240875 5.026852 1.0 1.0 mass
|
||||
3 309.133386 162.523019 72.798059 5.594199 1.0 1.0 mass
|
||||
4 312.887152 176.436760 83.754277 -1.370025 1.0 1.0 mass
|
||||
5 321.660596 187.895952 91.634021 -8.308630 1.0 1.0 mass
|
||||
6 335.256132 192.503856 94.772924 -18.985044 1.0 1.0 mass
|
||||
7 348.254504 188.731936 92.657963 -29.982110 1.0 1.0 mass
|
||||
8 359.050972 180.780059 86.668616 -39.817638 1.0 1.0 mass
|
||||
9 363.685639 167.752177 76.554871 -47.987107 1.0 1.0 mass
|
||||
10 360.449954 154.092353 57.992242 -48.045772 1.0 1.0 mass
|
||||
11 352.201411 142.382665 41.200547 -39.924209 1.0 1.0 mass
|
||||
12 338.754859 137.460615 32.306364 -22.707784 1.0 1.0 mass
|
||||
13 312.911184 114.835962 8.342965 5.878311 1.0 1.0 mass
|
||||
14 290.521818 132.872407 33.212103 28.391710 1.0 1.0 mass
|
||||
15 281.048450 160.314206 66.319674 32.935324 1.0 1.0 mass
|
||||
16 287.450075 188.730522 93.898071 21.966741 1.0 1.0 mass
|
||||
17 305.987715 211.206959 112.571044 5.089593 1.0 1.0 mass
|
||||
18 333.289699 220.830317 121.166705 -17.204713 1.0 1.0 mass
|
||||
19 361.089678 214.901909 117.183695 -41.776506 1.0 1.0 mass
|
||||
20 382.690515 197.005784 101.789802 -63.980298 1.0 1.0 mass
|
||||
21 392.095364 170.108402 75.453780 -78.414351 1.0 1.0 mass
|
||||
22 386.286391 142.033621 41.812216 -77.402424 1.0 1.0 mass
|
||||
23 368.355658 119.326317 12.658676 -58.885262 1.0 1.0 mass
|
||||
24 341.159901 109.253775 -0.645459 -27.346079 1.0 1.0 mass
|
||||
25 300.792976 88.652764 -23.770230 17.788258 1.0 1.0 mass
|
||||
26 266.917041 116.942125 11.387083 52.603190 1.0 1.0 mass
|
||||
27 252.824303 157.992984 59.144863 62.163730 1.0 1.0 mass
|
||||
28 261.812599 201.245775 103.542171 47.141708 1.0 1.0 mass
|
||||
29 290.323965 234.792944 133.016945 18.136362 1.0 1.0 mass
|
||||
30 330.805232 249.331769 145.899409 -16.478401 1.0 1.0 mass
|
||||
31 373.715232 241.181453 141.068680 -55.103677 1.0 1.0 mass
|
||||
32 406.314817 213.217096 116.087430 -90.844012 1.0 1.0 mass
|
||||
33 420.647493 172.661774 73.304028 -110.880720 1.0 1.0 mass
|
||||
34 412.375908 129.697207 24.072484 -106.129512 1.0 1.0 mass
|
||||
35 384.555754 95.915740 -16.565355 -77.142380 1.0 1.0 mass
|
||||
36 344.134757 80.886540 -34.250916 -30.871105 1.0 1.0 mass
|
||||
37 288.774590 62.672780 -55.431084 28.821437 1.0 1.0 mass
|
||||
38 244.055965 100.457489 -9.756397 76.701354 1.0 1.0 mass
|
||||
39 224.574635 156.693148 53.845562 91.755892 1.0 1.0 mass
|
||||
40 235.856891 213.935639 112.462316 73.437061 1.0 1.0 mass
|
||||
41 273.697931 257.991035 152.320671 33.701056 1.0 1.0 mass
|
||||
42 329.129445 277.782400 170.727571 -15.899371 1.0 1.0 mass
|
||||
43 386.065290 267.474982 165.436658 -68.761273 1.0 1.0 mass
|
||||
44 429.946314 229.605765 132.087682 -116.795195 1.0 1.0 mass
|
||||
45 449.164590 174.189613 73.084826 -143.228528 1.0 1.0 mass
|
||||
46 438.674101 117.351918 9.340834 -136.225613 1.0 1.0 mass
|
||||
47 401.586435 72.955570 -42.523445 -98.317857 1.0 1.0 mass
|
||||
48 346.207804 52.561279 -67.447974 -34.980297 1.0 1.0 mass
|
||||
1 1 2 150.0 2.0 14.0 spng
|
||||
2 2 3 150.0 2.0 14.0 spng
|
||||
3 3 4 150.0 2.0 14.0 spng
|
||||
4 4 5 150.0 2.0 14.0 spng
|
||||
5 5 6 150.0 2.0 14.0 spng
|
||||
6 6 7 150.0 2.0 14.0 spng
|
||||
7 7 8 150.0 2.0 14.0 spng
|
||||
8 8 9 150.0 2.0 14.0 spng
|
||||
9 9 10 150.0 2.0 14.0 spng
|
||||
10 10 11 150.0 2.0 14.0 spng
|
||||
11 11 12 150.0 2.0 14.0 spng
|
||||
12 12 1 150.0 2.0 14.0 spng
|
||||
13 13 14 150.0 2.0 28.0 spng
|
||||
14 14 15 150.0 2.0 28.0 spng
|
||||
15 15 16 150.0 2.0 28.0 spng
|
||||
16 16 17 150.0 2.0 28.0 spng
|
||||
17 17 18 150.0 2.0 28.0 spng
|
||||
18 18 19 150.0 2.0 28.0 spng
|
||||
19 19 20 150.0 2.0 28.0 spng
|
||||
20 20 21 150.0 2.0 28.0 spng
|
||||
21 21 22 150.0 2.0 28.0 spng
|
||||
22 22 23 150.0 2.0 28.0 spng
|
||||
23 23 24 150.0 2.0 28.0 spng
|
||||
24 24 13 150.0 2.0 28.0 spng
|
||||
25 25 26 150.0 2.0 44.0 spng
|
||||
26 26 27 150.0 2.0 43.0 spng
|
||||
27 27 28 150.0 2.0 44.0 spng
|
||||
28 28 29 150.0 2.0 44.0 spng
|
||||
29 29 30 150.0 2.0 43.0 spng
|
||||
30 30 31 150.0 2.0 44.0 spng
|
||||
31 31 32 150.0 2.0 43.0 spng
|
||||
32 32 33 150.0 2.0 43.0 spng
|
||||
33 33 34 150.0 2.0 44.0 spng
|
||||
34 34 35 150.0 2.0 44.0 spng
|
||||
35 35 36 150.0 2.0 43.0 spng
|
||||
36 36 25 150.0 2.0 44.0 spng
|
||||
37 37 38 150.0 2.0 58.0 spng
|
||||
38 38 39 150.0 2.0 59.0 spng
|
||||
39 39 40 150.0 2.0 58.0 spng
|
||||
40 40 41 150.0 2.0 58.0 spng
|
||||
41 41 42 150.0 2.0 59.0 spng
|
||||
42 42 43 150.0 2.0 58.0 spng
|
||||
43 43 44 150.0 2.0 58.0 spng
|
||||
44 44 45 150.0 2.0 59.0 spng
|
||||
45 45 46 150.0 2.0 58.0 spng
|
||||
46 46 47 150.0 2.0 58.0 spng
|
||||
47 47 48 150.0 2.0 59.0 spng
|
||||
48 48 37 150.0 2.0 58.0 spng
|
||||
49 1 13 150.0 2.0 29.0 spng
|
||||
50 2 14 150.0 2.0 28.0 spng
|
||||
51 3 15 150.0 2.0 28.0 spng
|
||||
52 4 16 150.0 2.0 29.0 spng
|
||||
53 5 17 150.0 2.0 28.0 spng
|
||||
54 6 18 150.0 2.0 28.0 spng
|
||||
55 7 19 150.0 2.0 29.0 spng
|
||||
56 8 20 150.0 2.0 28.0 spng
|
||||
57 9 21 150.0 2.0 28.0 spng
|
||||
58 10 22 150.0 2.0 29.0 spng
|
||||
59 11 23 150.0 2.0 28.0 spng
|
||||
60 12 24 150.0 2.0 28.0 spng
|
||||
61 13 25 150.0 2.0 29.0 spng
|
||||
62 14 26 150.0 2.0 28.0 spng
|
||||
63 15 27 150.0 2.0 28.0 spng
|
||||
64 16 28 150.0 2.0 29.0 spng
|
||||
65 17 29 150.0 2.0 28.0 spng
|
||||
66 18 30 150.0 2.0 28.0 spng
|
||||
67 19 31 150.0 2.0 29.0 spng
|
||||
68 20 32 150.0 2.0 28.0 spng
|
||||
69 21 33 150.0 2.0 28.0 spng
|
||||
70 22 34 150.0 2.0 29.0 spng
|
||||
71 23 35 150.0 2.0 28.0 spng
|
||||
72 24 36 150.0 2.0 28.0 spng
|
||||
73 25 37 150.0 2.0 29.0 spng
|
||||
74 26 38 150.0 2.0 28.0 spng
|
||||
75 27 39 150.0 2.0 28.0 spng
|
||||
76 28 40 150.0 2.0 29.0 spng
|
||||
77 29 41 150.0 2.0 28.0 spng
|
||||
78 30 42 150.0 2.0 28.0 spng
|
||||
79 31 43 150.0 2.0 29.0 spng
|
||||
80 32 44 150.0 2.0 28.0 spng
|
||||
81 33 45 150.0 2.0 28.0 spng
|
||||
82 34 46 150.0 2.0 29.0 spng
|
||||
83 35 47 150.0 2.0 28.0 spng
|
||||
84 36 48 150.0 2.0 28.0 spng
|
||||
85 1 14 150.0 2.0 35.0 spng
|
||||
86 2 15 150.0 2.0 35.0 spng
|
||||
87 3 16 150.0 2.0 34.0 spng
|
||||
88 4 17 150.0 2.0 35.0 spng
|
||||
89 5 18 150.0 2.0 35.0 spng
|
||||
90 6 19 150.0 2.0 34.0 spng
|
||||
91 7 20 150.0 2.0 35.0 spng
|
||||
92 8 21 150.0 2.0 35.0 spng
|
||||
93 9 22 150.0 2.0 34.0 spng
|
||||
94 10 23 150.0 2.0 35.0 spng
|
||||
95 11 24 150.0 2.0 35.0 spng
|
||||
96 12 13 150.0 2.0 34.0 spng
|
||||
97 13 26 150.0 2.0 46.0 spng
|
||||
98 14 27 150.0 2.0 45.0 spng
|
||||
99 15 28 150.0 2.0 45.0 spng
|
||||
100 16 29 150.0 2.0 46.0 spng
|
||||
101 17 30 150.0 2.0 45.0 spng
|
||||
102 18 31 150.0 2.0 45.0 spng
|
||||
103 19 32 150.0 2.0 45.0 spng
|
||||
104 20 33 150.0 2.0 45.0 spng
|
||||
105 21 34 150.0 2.0 45.0 spng
|
||||
106 22 35 150.0 2.0 46.0 spng
|
||||
107 23 36 150.0 2.0 45.0 spng
|
||||
108 24 25 150.0 2.0 45.0 spng
|
||||
109 25 38 150.0 2.0 58.0 spng
|
||||
110 26 39 150.0 2.0 58.0 spng
|
||||
111 27 40 150.0 2.0 58.0 spng
|
||||
112 28 41 150.0 2.0 58.0 spng
|
||||
113 29 42 150.0 2.0 58.0 spng
|
||||
114 30 43 150.0 2.0 58.0 spng
|
||||
115 31 44 150.0 2.0 58.0 spng
|
||||
116 32 45 150.0 2.0 58.0 spng
|
||||
117 33 46 150.0 2.0 58.0 spng
|
||||
118 34 47 150.0 2.0 58.0 spng
|
||||
119 35 48 150.0 2.0 58.0 spng
|
||||
120 36 37 150.0 2.0 58.0 spng
|
||||
121 1 24 150.0 2.0 35.0 spng
|
||||
122 2 13 150.0 2.0 34.0 spng
|
||||
123 3 14 150.0 2.0 35.0 spng
|
||||
124 4 15 150.0 2.0 35.0 spng
|
||||
125 5 16 150.0 2.0 34.0 spng
|
||||
126 6 17 150.0 2.0 35.0 spng
|
||||
127 7 18 150.0 2.0 35.0 spng
|
||||
128 8 19 150.0 2.0 34.0 spng
|
||||
129 9 20 150.0 2.0 35.0 spng
|
||||
130 10 21 150.0 2.0 35.0 spng
|
||||
131 11 22 150.0 2.0 34.0 spng
|
||||
132 12 23 150.0 2.0 35.0 spng
|
||||
133 13 36 150.0 2.0 46.0 spng
|
||||
134 14 25 150.0 2.0 45.0 spng
|
||||
135 15 26 150.0 2.0 45.0 spng
|
||||
136 16 27 150.0 2.0 46.0 spng
|
||||
137 17 28 150.0 2.0 45.0 spng
|
||||
138 18 29 150.0 2.0 45.0 spng
|
||||
139 19 30 150.0 2.0 46.0 spng
|
||||
140 20 31 150.0 2.0 45.0 spng
|
||||
141 21 32 150.0 2.0 45.0 spng
|
||||
142 22 33 150.0 2.0 46.0 spng
|
||||
143 23 34 150.0 2.0 45.0 spng
|
||||
144 24 35 150.0 2.0 45.0 spng
|
||||
145 25 48 150.0 2.0 58.0 spng
|
||||
146 26 37 150.0 2.0 58.0 spng
|
||||
147 27 38 150.0 2.0 58.0 spng
|
||||
148 28 39 150.0 2.0 58.0 spng
|
||||
149 29 40 150.0 2.0 58.0 spng
|
||||
150 30 41 150.0 2.0 58.0 spng
|
||||
151 31 42 150.0 2.0 58.0 spng
|
||||
152 32 43 150.0 2.0 58.0 spng
|
||||
153 33 44 150.0 2.0 58.0 spng
|
||||
154 34 45 150.0 2.0 58.0 spng
|
||||
155 35 46 150.0 2.0 58.0 spng
|
||||
156 36 47 150.0 2.0 58.0 spng
|
||||
157 10 4 150.0 2.0 52.331631 spng
|
||||
158 7 1 150.0 2.0 52.436772 spng
|
||||
159 12 6 150.0 2.0 54.680698 spng
|
||||
160 5 11 150.0 2.0 54.589379 spng
|
||||
161 9 3 150.0 2.0 54.451569 spng
|
||||
162 2 8 150.0 2.0 54.482231 spng
|
||||
163 45 11 150.0 2.0 101.408150 spng
|
||||
164 46 12 150.0 2.0 101.542452 spng
|
||||
165 47 1 150.0 2.0 101.963064 spng
|
||||
166 48 2 150.0 2.0 101.517329 spng
|
||||
167 37 3 150.0 2.0 101.603694 spng
|
||||
168 38 4 150.0 2.0 102.014031 spng
|
||||
169 39 5 150.0 2.0 101.547660 spng
|
||||
170 40 6 150.0 2.0 101.573762 spng
|
||||
171 41 7 150.0 2.0 101.897300 spng
|
||||
172 42 8 150.0 2.0 101.497982 spng
|
||||
173 43 9 150.0 2.0 101.870594 spng
|
||||
174 44 10 150.0 2.0 102.043753 spng
|
||||
175 45 11 150.0 2.0 101.408150 spng
|
||||
176 46 8 150.0 2.0 101.548938 spng
|
||||
177 47 10 150.0 2.0 90.645939 spng
|
||||
178 48 10 150.0 2.0 101.952119 spng
|
||||
179 37 11 150.0 2.0 101.552352 spng
|
||||
180 38 12 150.0 2.0 101.491447 spng
|
||||
181 39 1 150.0 2.0 101.971524 spng
|
||||
182 40 2 150.0 2.0 101.587400 spng
|
||||
183 41 3 150.0 2.0 101.519279 spng
|
||||
184 42 4 150.0 2.0 101.976181 spng
|
||||
185 43 5 150.0 2.0 101.714570 spng
|
||||
186 44 6 150.0 2.0 101.388747 spng
|
||||
187 45 7 150.0 2.0 101.773286 spng
|
||||
|
||||
nodes> [ { 0 100 } swap set-node-vel ] each ;
|
||||
|
||||
USING: threads ui ;
|
||||
|
||||
: go ( -- ) [ [ springies-window* 1000 sleep model ] with-scope ] with-ui ;
|
||||
|
||||
MAIN: go
|
||||
|
|
@ -0,0 +1,246 @@
|
|||
|
||||
USING: kernel combinators sequences arrays math math.vectors
|
||||
combinators.lib shuffle vars ;
|
||||
|
||||
IN: springies
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: scalar-projection ( a b -- n ) [ v. ] [ nip norm ] 2bi / ;
|
||||
|
||||
: vector-projection ( a b -- vec )
|
||||
[ nip normalize ] [ scalar-projection ] 2bi v*n ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
VAR: nodes
|
||||
VAR: springs
|
||||
VAR: time-slice
|
||||
VAR: world-size
|
||||
|
||||
: world-width ( -- width ) world-size> first ;
|
||||
|
||||
: world-height ( -- height ) world-size> second ;
|
||||
|
||||
VAR: gravity
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
! node
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
TUPLE: node mass elas pos vel force ;
|
||||
|
||||
C: <node> node
|
||||
|
||||
: >>pos ( node pos -- node ) over set-node-pos ;
|
||||
|
||||
: >>vel ( node vel -- node ) over set-node-vel ;
|
||||
|
||||
: pos-x ( node -- x ) node-pos first ;
|
||||
: pos-y ( node -- y ) node-pos second ;
|
||||
: vel-x ( node -- y ) node-vel first ;
|
||||
: vel-y ( node -- y ) node-vel second ;
|
||||
|
||||
: >>pos-x ( node x -- node ) over node-pos set-first ;
|
||||
: >>pos-y ( node y -- node ) over node-pos set-second ;
|
||||
: >>vel-x ( node x -- node ) over node-vel set-first ;
|
||||
: >>vel-y ( node y -- node ) over node-vel set-second ;
|
||||
|
||||
: apply-force ( node vec -- ) over node-force v+ swap set-node-force ;
|
||||
|
||||
: reset-force ( node -- ) 0 0 2array swap set-node-force ;
|
||||
|
||||
: node-id ( id -- node ) 1- nodes> nth ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
! spring
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
TUPLE: spring rest-length k damp node-a node-b ;
|
||||
|
||||
C: <spring> spring
|
||||
|
||||
: end-points ( spring -- b-pos a-pos )
|
||||
[ spring-node-b node-pos ] [ spring-node-a node-pos ] bi ;
|
||||
|
||||
: spring-length ( spring -- length ) end-points v- norm ;
|
||||
|
||||
: stretch-length ( spring -- length )
|
||||
[ spring-length ] [ spring-rest-length ] bi - ;
|
||||
|
||||
: dir ( spring -- vec ) end-points v- normalize ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
! Hooke
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
!
|
||||
! F = -kx
|
||||
!
|
||||
! k :: spring constant
|
||||
! x :: distance stretched beyond rest length
|
||||
!
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: hooke-force-mag ( spring -- mag ) [ spring-k ] [ stretch-length ] bi * ;
|
||||
|
||||
: hooke-force ( spring -- force ) [ dir ] [ hooke-force-mag ] bi v*n ;
|
||||
|
||||
: hooke-forces ( spring -- a b ) hooke-force dup vneg ;
|
||||
|
||||
: act-on-nodes-hooke ( spring -- )
|
||||
[ spring-node-a ] [ spring-node-b ] [ ] tri hooke-forces swapd
|
||||
apply-force
|
||||
apply-force ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
! damping
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
!
|
||||
! F = -bv
|
||||
!
|
||||
! b :: Damping constant
|
||||
! v :: Velocity
|
||||
!
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
! : damping-force-a ( spring -- vec )
|
||||
! [ spring-node-a node-vel ] [ spring-damp ] bi v*n vneg ;
|
||||
|
||||
! : damping-force-b ( spring -- vec )
|
||||
! [ spring-node-b node-vel ] [ spring-damp ] bi v*n vneg ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: relative-velocity-a ( spring -- vel )
|
||||
[ spring-node-a node-vel ] [ spring-node-b node-vel ] bi v- ;
|
||||
|
||||
: unit-vec-b->a ( spring -- vec )
|
||||
[ spring-node-a node-pos ] [ spring-node-b node-pos ] bi v- ;
|
||||
|
||||
: relative-velocity-along-spring-a ( spring -- vel )
|
||||
[ relative-velocity-a ] [ unit-vec-b->a ] bi vector-projection ;
|
||||
|
||||
: damping-force-a ( spring -- vec )
|
||||
[ relative-velocity-along-spring-a ] [ spring-damp ] bi v*n vneg ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: relative-velocity-b ( spring -- vel )
|
||||
[ spring-node-b node-vel ] [ spring-node-a node-vel ] bi v- ;
|
||||
|
||||
: unit-vec-a->b ( spring -- vec )
|
||||
[ spring-node-b node-pos ] [ spring-node-a node-pos ] bi v- ;
|
||||
|
||||
: relative-velocity-along-spring-b ( spring -- vel )
|
||||
[ relative-velocity-b ] [ unit-vec-a->b ] bi vector-projection ;
|
||||
|
||||
: damping-force-b ( spring -- vec )
|
||||
[ relative-velocity-along-spring-b ] [ spring-damp ] bi v*n vneg ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: act-on-nodes-damping ( spring -- )
|
||||
dup
|
||||
[ spring-node-a ] [ damping-force-a ] bi apply-force
|
||||
[ spring-node-b ] [ damping-force-b ] bi apply-force ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: below? ( node -- ? ) pos-y 0 < ;
|
||||
|
||||
: above? ( node -- ? ) pos-y world-height >= ;
|
||||
|
||||
: beyond-left? ( node -- ? ) pos-x 0 < ;
|
||||
|
||||
: beyond-right? ( node -- ? ) pos-x world-width >= ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: bounce-top ( node -- )
|
||||
world-height 1- >>pos-y
|
||||
dup [ vel-y ] [ node-elas ] bi * neg >>vel-y
|
||||
drop ;
|
||||
|
||||
: bounce-bottom ( node -- )
|
||||
0 >>pos-y
|
||||
dup [ vel-y ] [ node-elas ] bi * neg >>vel-y
|
||||
drop ;
|
||||
|
||||
: bounce-left ( node -- )
|
||||
0 >>pos-x
|
||||
dup [ vel-x ] [ node-elas ] bi * neg >>vel-x
|
||||
drop ;
|
||||
|
||||
: bounce-right ( node -- )
|
||||
world-width 1- >>pos-x
|
||||
dup [ vel-x ] [ node-elas ] bi * neg >>vel-x
|
||||
drop ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: handle-bounce ( node -- )
|
||||
{ { [ dup above? ] [ bounce-top ] }
|
||||
{ [ dup below? ] [ bounce-bottom ] }
|
||||
{ [ dup beyond-left? ] [ bounce-left ] }
|
||||
{ [ dup beyond-right? ] [ bounce-right ] }
|
||||
{ [ t ] [ drop ] } }
|
||||
cond ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: act-on-nodes ( spring -- )
|
||||
dup
|
||||
act-on-nodes-hooke
|
||||
act-on-nodes-damping ;
|
||||
|
||||
! : act-on-nodes ( spring -- ) act-on-nodes-hooke ;
|
||||
|
||||
: loop-over-springs ( -- ) springs> [ act-on-nodes ] each ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: apply-gravity ( node -- ) { 0 -9.8 } apply-force ;
|
||||
|
||||
: do-gravity ( -- ) gravity> [ nodes> [ apply-gravity ] each ] when ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
! F = ma
|
||||
|
||||
: calc-acceleration ( node -- vec ) [ node-force ] [ node-mass ] bi v/n ;
|
||||
|
||||
: new-vel ( node -- vel )
|
||||
[ node-vel ] [ calc-acceleration time-slice> v*n ] bi v+ ;
|
||||
|
||||
: new-pos ( node -- pos ) [ node-pos ] [ node-vel time-slice> v*n ] bi v+ ;
|
||||
|
||||
: iterate-node ( node -- )
|
||||
dup new-pos >>pos
|
||||
dup new-vel >>vel
|
||||
dup reset-force
|
||||
handle-bounce ;
|
||||
|
||||
: iterate-nodes ( -- ) nodes> [ iterate-node ] each ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: iterate-system ( -- ) do-gravity loop-over-springs iterate-nodes ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
! Reading xspringies data files
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: mass ( id x y x-vel y-vel mass elas -- )
|
||||
7 nrot drop
|
||||
6 nrot 6 nrot 2array
|
||||
5 nrot 5 nrot 2array
|
||||
0 0 2array <node>
|
||||
nodes> swap add >nodes ;
|
||||
|
||||
: spng ( id id-a id-b k damp rest-length -- )
|
||||
6 nrot drop
|
||||
-rot
|
||||
5 nrot node-id
|
||||
5 nrot node-id
|
||||
<spring>
|
||||
springs> swap add >springs ;
|
||||
|
|
@ -0,0 +1,61 @@
|
|||
|
||||
USING: kernel namespaces threads sequences math math.vectors combinators.lib
|
||||
opengl.gl opengl colors ui ui.gadgets ui.gadgets.slate
|
||||
rewrite-closures vars springies ;
|
||||
|
||||
IN: springies.ui
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: draw-node ( node -- ) node-pos { -5 -5 } v+ dup { 10 10 } v+ gl-rect ;
|
||||
|
||||
: draw-spring ( spring -- )
|
||||
[ spring-node-a node-pos ] [ spring-node-b node-pos ] bi gl-line ;
|
||||
|
||||
: draw-nodes ( -- ) nodes> [ draw-node ] each ;
|
||||
|
||||
: draw-springs ( -- ) springs> [ draw-spring ] each ;
|
||||
|
||||
: set-projection ( -- )
|
||||
GL_PROJECTION glMatrixMode
|
||||
glLoadIdentity
|
||||
0 world-width 1- 0 world-height 1- -1 1 glOrtho
|
||||
GL_MODELVIEW glMatrixMode
|
||||
glLoadIdentity ;
|
||||
|
||||
: display ( -- ) set-projection black gl-color draw-nodes draw-springs ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
VAR: slate
|
||||
|
||||
VAR: loop
|
||||
|
||||
: update-world-size ( -- ) slate> rect-dim >world-size ;
|
||||
|
||||
: refresh-slate ( -- ) slate> relayout-1 ;
|
||||
|
||||
DEFER: maybe-loop
|
||||
|
||||
: run ( -- )
|
||||
update-world-size
|
||||
iterate-system
|
||||
refresh-slate
|
||||
yield
|
||||
maybe-loop ;
|
||||
|
||||
: maybe-loop ( -- ) loop> [ run ] when ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: springies-window* ( -- )
|
||||
|
||||
C[ display ] <slate> >slate
|
||||
{ 500 500 } slate> set-slate-dim
|
||||
C[ { 500 500 } >world-size loop on [ run ] in-thread ]
|
||||
slate> set-slate-graft
|
||||
C[ loop off ] slate> set-slate-ungraft
|
||||
|
||||
slate> "Springies" open-window ;
|
||||
|
||||
: springies-window ( -- ) [ [ springies-window* ] with-scope ] with-ui ;
|
||||
|
|
@ -1,4 +1,4 @@
|
|||
USING: tools.deploy ;
|
||||
USING: tools.deploy.config ;
|
||||
V{
|
||||
{ strip-word-props? t }
|
||||
{ strip-word-names? t }
|
||||
|
|
|
|||
|
|
@ -1,8 +1,8 @@
|
|||
! Copyright (C) 2007 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: io io.files io.launcher kernel namespaces sequences
|
||||
system cocoa.plists cocoa.application tools.deploy assocs
|
||||
hashtables prettyprint ;
|
||||
system cocoa.plists cocoa.application tools.deploy
|
||||
tools.deploy.config assocs hashtables prettyprint ;
|
||||
IN: tools.deploy.app
|
||||
|
||||
: mkdir ( path -- )
|
||||
|
|
|
|||
|
|
@ -0,0 +1,105 @@
|
|||
USING: help.markup help.syntax words alien.c-types assocs
|
||||
kernel ;
|
||||
IN: tools.deploy.config
|
||||
|
||||
ARTICLE: "deploy-config" "Deployment configuration"
|
||||
"The deployment configuration is a key/value mapping stored in the " { $snippet "deploy.factor" } " file in the vocabulary's directory. If this file does not exist, the default deployment configuration is used:"
|
||||
{ $subsection default-config }
|
||||
"The deployment configuration can be read and written with a pair of words:"
|
||||
{ $subsection deploy-config }
|
||||
{ $subsection set-deploy-config }
|
||||
"A utility word is provided to load the configuration, change a flag, and store it back to disk:"
|
||||
{ $subsection set-deploy-flag } ;
|
||||
|
||||
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-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? } ;
|
||||
|
||||
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."
|
||||
{ $subsection "deploy-config" }
|
||||
{ $subsection "deploy-flags" } ;
|
||||
|
||||
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."
|
||||
$nl
|
||||
"On by default. Disable this if the heuristics strip out required variables." } ;
|
||||
|
||||
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."
|
||||
$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." } ;
|
||||
|
||||
HELP: deploy-math?
|
||||
{ $description "Deploy flag. If set, the deployed image will contain the full number tower."
|
||||
$nl
|
||||
"On by default. Most programs require the number tower, in particular, any program deployed with " { $link deploy-compiled? } " set." } ;
|
||||
|
||||
HELP: deploy-compiled?
|
||||
{ $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." } ;
|
||||
|
||||
HELP: deploy-ui?
|
||||
{ $description "Deploy flag. If set, the Factor UI will be included in the deployed image."
|
||||
$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: default-config
|
||||
{ $values { "assoc" assoc } }
|
||||
{ $description "Outputs the default deployment configuration." } ;
|
||||
|
||||
HELP: deploy-config
|
||||
{ $values { "vocab" "a vocabulary specifier" } { "assoc" assoc } }
|
||||
{ $description "Loads a vocabulary's deployment configuration from the " { $snippet "deploy.factor" } " file in the vocabulary's directory. If the file does not exist, the " { $link default-config } " is output." } ;
|
||||
|
||||
HELP: set-deploy-config
|
||||
{ $values { "assoc" assoc } { "vocab" "a vocabulary specifier" } }
|
||||
{ $description "Stores a vocabulary's deployment configuration to the " { $snippet "deploy.factor" } " file in the vocabulary's directory." } ;
|
||||
|
||||
HELP: set-deploy-flag
|
||||
{ $values { "value" object } { "key" object } { "vocab" "a vocabulary specifier" } }
|
||||
{ $description "Modifies an entry in a vocabulary's deployment configuration on disk." } ;
|
||||
|
|
@ -0,0 +1,53 @@
|
|||
! 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 ;
|
||||
IN: tools.deploy.config
|
||||
|
||||
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-vm
|
||||
SYMBOL: deploy-image
|
||||
|
||||
: default-config ( -- assoc )
|
||||
V{
|
||||
{ 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 }
|
||||
! default value for deploy.app
|
||||
{ "stop-after-last-window?" t }
|
||||
} clone ;
|
||||
|
||||
: deploy-config-path ( vocab -- string )
|
||||
vocab-dir "deploy.factor" path+ ;
|
||||
|
||||
: deploy-config ( vocab -- assoc )
|
||||
default-config swap
|
||||
dup deploy-config-path vocab-file-contents
|
||||
parse-fresh dup empty? [ drop ] [ first union ] if ;
|
||||
|
||||
: set-deploy-config ( assoc vocab -- )
|
||||
>r unparse-use string-lines r>
|
||||
dup deploy-config-path set-vocab-file-contents ;
|
||||
|
||||
: set-deploy-flag ( value key vocab -- )
|
||||
[ deploy-config [ set-at ] keep ] keep set-deploy-config ;
|
||||
|
|
@ -2,30 +2,6 @@ USING: help.markup help.syntax words alien.c-types assocs
|
|||
kernel ;
|
||||
IN: tools.deploy
|
||||
|
||||
ARTICLE: "deploy-config" "Deployment configuration"
|
||||
"The deployment configuration is a key/value mapping stored in the " { $snippet "deploy.factor" } " file in the vocabulary's directory. If this file does not exist, the default deployment configuration is used:"
|
||||
{ $subsection default-config }
|
||||
"The deployment configuration can be read and written with a pair of words:"
|
||||
{ $subsection deploy-config }
|
||||
{ $subsection set-deploy-config }
|
||||
"A utility word is provided to load the configuration, change a flag, and store it back to disk:"
|
||||
{ $subsection set-deploy-flag } ;
|
||||
|
||||
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-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? } ;
|
||||
|
||||
ARTICLE: "tools.deploy" "Stand-alone image deployment"
|
||||
"The stand-alone image deployment tool takes a vocabulary and generates an image, which when passed to the VM, runs the vocabulary's " { $link POSTPONE: MAIN: } " hook."
|
||||
$nl
|
||||
|
|
@ -33,85 +9,12 @@ $nl
|
|||
{ $code "\"hello-world\" deploy" }
|
||||
"This generates an image file named " { $snippet "hello-world.image" } ". Now we can start this image from the operating system's command line (see " { $link "runtime-cli-args" } "):"
|
||||
{ $code "./factor -i=hello-world.image" "Hello world" }
|
||||
"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."
|
||||
{ $subsection "deploy-config" }
|
||||
{ $subsection "deploy-flags" }
|
||||
|
||||
"Once the necessary deployment flags have been set, a deployment image can be generated:"
|
||||
{ $subsection deploy } ;
|
||||
|
||||
ABOUT: "tools.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."
|
||||
$nl
|
||||
"On by default. Disable this if the heuristics strip out required variables." } ;
|
||||
|
||||
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."
|
||||
$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." } ;
|
||||
|
||||
HELP: deploy-math?
|
||||
{ $description "Deploy flag. If set, the deployed image will contain the full number tower."
|
||||
$nl
|
||||
"On by default. Most programs require the number tower, in particular, any program deployed with " { $link deploy-compiled? } " set." } ;
|
||||
|
||||
HELP: deploy-compiled?
|
||||
{ $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." } ;
|
||||
|
||||
HELP: deploy-ui?
|
||||
{ $description "Deploy flag. If set, the Factor UI will be included in the deployed image."
|
||||
$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: default-config
|
||||
{ $values { "assoc" assoc } }
|
||||
{ $description "Outputs the default deployment configuration." } ;
|
||||
|
||||
HELP: deploy-config
|
||||
{ $values { "vocab" "a vocabulary specifier" } { "assoc" assoc } }
|
||||
{ $description "Loads a vocabulary's deployment configuration from the " { $snippet "deploy.factor" } " file in the vocabulary's directory. If the file does not exist, the " { $link default-config } " is output." } ;
|
||||
|
||||
HELP: set-deploy-config
|
||||
{ $values { "assoc" assoc } { "vocab" "a vocabulary specifier" } }
|
||||
{ $description "Stores a vocabulary's deployment configuration to the " { $snippet "deploy.factor" } " file in the vocabulary's directory." } ;
|
||||
|
||||
HELP: set-deploy-flag
|
||||
{ $values { "value" object } { "key" object } { "vocab" "a vocabulary specifier" } }
|
||||
{ $description "Modifies an entry in a vocabulary's deployment configuration on disk." } ;
|
||||
|
||||
HELP: deploy*
|
||||
{ $values { "vm" "a pathname string" } { "image" "a pathname string" } { "vocab" "a vocabulary specifier" } { "config" assoc } }
|
||||
{ $description "Deploys " { $snippet "vocab" } ", which must have a " { $link POSTPONE: MAIN: } " hook, using the specified VM and configuration. The deployed image is saved as " { $snippet "image" } "." }
|
||||
|
|
|
|||
|
|
@ -5,255 +5,30 @@ assocs kernel vocabs words sequences memory io system arrays
|
|||
continuations math definitions mirrors splitting parser classes
|
||||
inspector layouts vocabs.loader prettyprint.config prettyprint
|
||||
debugger io.streams.c io.streams.duplex io.files io.backend
|
||||
quotations io.launcher words.private ;
|
||||
quotations io.launcher words.private tools.deploy.config ;
|
||||
IN: tools.deploy
|
||||
|
||||
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-vm
|
||||
SYMBOL: deploy-image
|
||||
|
||||
: default-config ( -- assoc )
|
||||
V{
|
||||
{ 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 }
|
||||
! default value for deploy.app
|
||||
{ "stop-after-last-window?" t }
|
||||
} clone ;
|
||||
|
||||
: deploy-config-path ( vocab -- string )
|
||||
vocab-dir "deploy.factor" path+ ;
|
||||
|
||||
: deploy-config ( vocab -- assoc )
|
||||
default-config swap
|
||||
dup deploy-config-path vocab-file-contents
|
||||
parse-fresh dup empty? [ drop ] [ first union ] if ;
|
||||
|
||||
: set-deploy-config ( assoc vocab -- )
|
||||
>r unparse-use string-lines r>
|
||||
dup deploy-config-path set-vocab-file-contents ;
|
||||
|
||||
: set-deploy-flag ( value key vocab -- )
|
||||
[ deploy-config [ set-at ] keep ] keep set-deploy-config ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: show ( msg -- )
|
||||
#! Use primitives directly so that we can print stuff even
|
||||
#! after most of the image has been stripped away
|
||||
"\r\n" append stdout fwrite stdout fflush ;
|
||||
|
||||
: strip-init-hooks ( -- )
|
||||
"Stripping startup hooks" show
|
||||
"command-line" init-hooks get delete-at ;
|
||||
|
||||
: strip-debugger ( -- )
|
||||
strip-debugger? get [
|
||||
"Stripping debugger" show
|
||||
"resource:extra/tools/deploy/strip-debugger.factor"
|
||||
run-file
|
||||
] when ;
|
||||
|
||||
: strip-cocoa ( -- )
|
||||
"cocoa" vocab [
|
||||
"Stripping unused Cocoa methods" show
|
||||
"resource:extra/tools/deploy/strip-cocoa.factor"
|
||||
run-file
|
||||
] when ;
|
||||
|
||||
: strip-assoc ( retained-keys assoc -- newassoc )
|
||||
swap [ nip member? ] curry assoc-subset ;
|
||||
|
||||
: strip-word-names ( words -- )
|
||||
"Stripping word names" show
|
||||
[ f over set-word-name f swap set-word-vocabulary ] each ;
|
||||
|
||||
: strip-word-defs ( words -- )
|
||||
"Stripping unoptimized definitions from optimized words" show
|
||||
[ compiled? ] subset [ f swap set-word-def ] each ;
|
||||
|
||||
: strip-word-props ( retain-props words -- )
|
||||
"Stripping word properties" show
|
||||
[
|
||||
[ word-props strip-assoc f assoc-like ] keep
|
||||
set-word-props
|
||||
] curry* each ;
|
||||
|
||||
: retained-props ( -- seq )
|
||||
[
|
||||
"class" ,
|
||||
"metaclass" ,
|
||||
"slot-names" ,
|
||||
deploy-ui? get [
|
||||
"gestures" ,
|
||||
"commands" ,
|
||||
{ "+nullary+" "+listener+" "+description+" }
|
||||
[ "ui.commands" lookup , ] each
|
||||
] when
|
||||
] { } make ;
|
||||
|
||||
: strip-words ( props -- )
|
||||
[ word? ] instances
|
||||
strip-word-props? get [ tuck strip-word-props ] [ nip ] if
|
||||
strip-word-names? get [ 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 [
|
||||
global strip-assoc 21 setenv
|
||||
] [ drop ] if ;
|
||||
|
||||
: finish-deploy ( final-image -- )
|
||||
"Finishing up" show
|
||||
>r V{ } set-datastack r>
|
||||
V{ } set-retainstack
|
||||
V{ } set-callstack
|
||||
V{ } set-namestack
|
||||
V{ } set-catchstack
|
||||
"Saving final image" show
|
||||
[ save-image-and-exit ] call ;
|
||||
|
||||
SYMBOL: deploy-vocab
|
||||
|
||||
: set-boot-quot* ( word -- )
|
||||
[
|
||||
\ boot ,
|
||||
init-hooks get values concat %
|
||||
,
|
||||
"io.backend" init-hooks get at [ \ flush , ] when
|
||||
] [ ] make "Boot quotation: " write dup . flush
|
||||
set-boot-quot ;
|
||||
|
||||
: retained-globals ( -- seq )
|
||||
[
|
||||
builtins ,
|
||||
io-backend ,
|
||||
|
||||
strip-dictionary? get [
|
||||
{
|
||||
builtins
|
||||
dictionary
|
||||
inspector-hook
|
||||
lexer-factory
|
||||
load-vocab-hook
|
||||
num-tags
|
||||
num-types
|
||||
tag-bits
|
||||
tag-mask
|
||||
tag-numbers
|
||||
typemap
|
||||
vocab-roots
|
||||
} %
|
||||
] unless
|
||||
|
||||
strip-prettyprint? get [
|
||||
{
|
||||
tab-size
|
||||
margin
|
||||
} %
|
||||
] unless
|
||||
|
||||
strip-c-types? get not deploy-ui? get or [
|
||||
"c-types" "alien.c-types" lookup ,
|
||||
] when
|
||||
|
||||
deploy-ui? get [
|
||||
"ui" child-vocabs
|
||||
"cocoa" child-vocabs
|
||||
deploy-vocab get child-vocabs 3append
|
||||
global keys [ word? ] subset
|
||||
swap [ >r word-vocabulary r> member? ] curry
|
||||
subset %
|
||||
] 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
|
||||
deploy-vocab get vocab-main set-boot-quot*
|
||||
retained-props >r
|
||||
retained-globals strip-environment
|
||||
r> strip-words ;
|
||||
|
||||
: (deploy) ( final-image vocab config -- )
|
||||
#! Does the actual work of a deployment in the slave
|
||||
#! stage2 image
|
||||
[
|
||||
[
|
||||
deploy-vocab set
|
||||
parse-hook get >r
|
||||
parse-hook off
|
||||
deploy-vocab get require
|
||||
r> call
|
||||
strip
|
||||
finish-deploy
|
||||
] [
|
||||
print-error flush 1 exit
|
||||
] recover
|
||||
] bind ;
|
||||
|
||||
: do-deploy ( -- )
|
||||
"output-image" get
|
||||
"deploy-vocab" get
|
||||
"Deploying " write dup write "..." print
|
||||
dup deploy-config dup .
|
||||
(deploy) ;
|
||||
|
||||
: (copy-lines) ( stream -- stream )
|
||||
dup stream-readln [ print flush (copy-lines) ] when* ;
|
||||
|
||||
: copy-lines ( stream -- )
|
||||
[ (copy-lines) ] [ stream-close ] [ ] cleanup ;
|
||||
|
||||
: boot-image-name ( -- string )
|
||||
cpu dup "ppc" = [ os "-" rot 3append ] when ;
|
||||
|
||||
: stage2 ( vm flags -- )
|
||||
[
|
||||
"\"" % swap % "\" -i=boot." % cpu % ".image" %
|
||||
"\"" % swap % "\" -i=boot." %
|
||||
boot-image-name
|
||||
% ".image" %
|
||||
[ " " % % ] each
|
||||
] "" make
|
||||
dup print <process-stream> copy-lines ;
|
||||
dup print <process-stream>
|
||||
dup duplex-stream-out stream-close
|
||||
copy-lines ;
|
||||
|
||||
: profile-string ( config -- string )
|
||||
{
|
||||
|
|
@ -283,5 +58,3 @@ PRIVATE>
|
|||
|
||||
: deploy ( vocab -- )
|
||||
vm over ".image" append rot dup deploy-config deploy* ;
|
||||
|
||||
MAIN: do-deploy
|
||||
|
|
|
|||
|
|
@ -0,0 +1,194 @@
|
|||
! Copyright (C) 2007 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: namespaces continuations.private kernel.private init
|
||||
assocs kernel vocabs words sequences memory io system arrays
|
||||
continuations math definitions mirrors splitting parser classes
|
||||
inspector layouts vocabs.loader prettyprint.config prettyprint
|
||||
debugger io.streams.c io.streams.duplex io.files io.backend
|
||||
quotations words.private tools.deploy.config ;
|
||||
IN: tools.deploy.shaker
|
||||
|
||||
: show ( msg -- )
|
||||
#! Use primitives directly so that we can print stuff even
|
||||
#! after most of the image has been stripped away
|
||||
"\r\n" append stdout fwrite stdout fflush ;
|
||||
|
||||
: strip-init-hooks ( -- )
|
||||
"Stripping startup hooks" show
|
||||
"command-line" init-hooks get delete-at ;
|
||||
|
||||
: strip-debugger ( -- )
|
||||
strip-debugger? get [
|
||||
"Stripping debugger" show
|
||||
"resource:extra/tools/deploy/strip-debugger.factor"
|
||||
run-file
|
||||
] when ;
|
||||
|
||||
: strip-cocoa ( -- )
|
||||
"cocoa" vocab [
|
||||
"Stripping unused Cocoa methods" show
|
||||
"resource:extra/tools/deploy/strip-cocoa.factor"
|
||||
run-file
|
||||
] when ;
|
||||
|
||||
: strip-assoc ( retained-keys assoc -- newassoc )
|
||||
swap [ nip member? ] curry assoc-subset ;
|
||||
|
||||
: strip-word-names ( words -- )
|
||||
"Stripping word names" show
|
||||
[ f over set-word-name f swap set-word-vocabulary ] each ;
|
||||
|
||||
: strip-word-defs ( words -- )
|
||||
"Stripping unoptimized definitions from optimized words" show
|
||||
[ compiled? ] subset [ [ ] swap set-word-def ] each ;
|
||||
|
||||
: strip-word-props ( retain-props words -- )
|
||||
"Stripping word properties" show
|
||||
[
|
||||
[ word-props strip-assoc f assoc-like ] keep
|
||||
set-word-props
|
||||
] curry* each ;
|
||||
|
||||
: retained-props ( -- seq )
|
||||
[
|
||||
"class" ,
|
||||
"metaclass" ,
|
||||
"slot-names" ,
|
||||
deploy-ui? get [
|
||||
"gestures" ,
|
||||
"commands" ,
|
||||
{ "+nullary+" "+listener+" "+description+" }
|
||||
[ "ui.commands" lookup , ] each
|
||||
] when
|
||||
] { } make ;
|
||||
|
||||
: strip-words ( props -- )
|
||||
[ word? ] instances
|
||||
strip-word-props? get [ tuck strip-word-props ] [ nip ] if
|
||||
strip-word-names? get [ 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 [
|
||||
global strip-assoc 21 setenv
|
||||
] [ drop ] if ;
|
||||
|
||||
: finish-deploy ( final-image -- )
|
||||
"Finishing up" show
|
||||
>r { } set-datastack r>
|
||||
{ } set-retainstack
|
||||
V{ } set-namestack
|
||||
V{ } set-catchstack
|
||||
"Saving final image" show
|
||||
[ save-image-and-exit ] call-clear ;
|
||||
|
||||
SYMBOL: deploy-vocab
|
||||
|
||||
: set-boot-quot* ( word -- )
|
||||
[
|
||||
\ boot ,
|
||||
init-hooks get values concat %
|
||||
,
|
||||
"io.backend" init-hooks get at [ \ flush , ] when
|
||||
] [ ] make "Boot quotation: " write dup . flush
|
||||
set-boot-quot ;
|
||||
|
||||
: retained-globals ( -- seq )
|
||||
[
|
||||
builtins ,
|
||||
io-backend ,
|
||||
|
||||
strip-dictionary? get [
|
||||
{
|
||||
builtins
|
||||
dictionary
|
||||
inspector-hook
|
||||
lexer-factory
|
||||
load-vocab-hook
|
||||
num-tags
|
||||
num-types
|
||||
tag-bits
|
||||
tag-mask
|
||||
tag-numbers
|
||||
typemap
|
||||
vocab-roots
|
||||
} %
|
||||
] unless
|
||||
|
||||
strip-prettyprint? get [
|
||||
{
|
||||
tab-size
|
||||
margin
|
||||
} %
|
||||
] unless
|
||||
|
||||
strip-c-types? get not deploy-ui? get or [
|
||||
"c-types" "alien.c-types" lookup ,
|
||||
] when
|
||||
|
||||
deploy-ui? get [
|
||||
"ui" child-vocabs
|
||||
"cocoa" child-vocabs
|
||||
deploy-vocab get child-vocabs 3append
|
||||
global keys [ word? ] subset
|
||||
swap [ >r word-vocabulary r> member? ] curry
|
||||
subset %
|
||||
] 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
|
||||
deploy-vocab get vocab-main set-boot-quot*
|
||||
retained-props >r
|
||||
retained-globals strip-environment
|
||||
r> strip-words ;
|
||||
|
||||
: (deploy) ( final-image vocab config -- )
|
||||
#! Does the actual work of a deployment in the slave
|
||||
#! stage2 image
|
||||
[
|
||||
[
|
||||
deploy-vocab set
|
||||
parse-hook get >r
|
||||
parse-hook off
|
||||
deploy-vocab get require
|
||||
r> [ call ] when*
|
||||
strip
|
||||
finish-deploy
|
||||
] [
|
||||
print-error flush 1 exit
|
||||
] recover
|
||||
] bind ;
|
||||
|
||||
: do-deploy ( -- )
|
||||
"output-image" get
|
||||
"deploy-vocab" get
|
||||
"Deploying " write dup write "..." print
|
||||
dup deploy-config dup .
|
||||
(deploy) ;
|
||||
|
||||
MAIN: do-deploy
|
||||
|
|
@ -1,7 +1,8 @@
|
|||
USING: arrays continuations ui.tools.listener ui.tools.walker
|
||||
ui.tools.workspace inspector kernel namespaces sequences threads
|
||||
listener tools.test ui ui.gadgets ui.gadgets.worlds
|
||||
ui.gadgets.packs vectors ui.tools ;
|
||||
ui.gadgets.packs vectors ui.tools tools.interpreter
|
||||
tools.interpreter.debug ;
|
||||
IN: temporary
|
||||
|
||||
[ ] [ <walker> "walker" set ] unit-test
|
||||
|
|
@ -51,3 +52,17 @@ IN: temporary
|
|||
swap second \ inspect eq? and
|
||||
] unit-test
|
||||
] with-scope
|
||||
|
||||
[
|
||||
f <workspace> <test-world> 2array 1vector windows set
|
||||
|
||||
[ ] [
|
||||
[ 2 3 break 4 ] quot>cont f swap 2array walker call-tool
|
||||
] unit-test
|
||||
|
||||
[ ] [ walker get-tool com-continue ] unit-test
|
||||
|
||||
[ ] [ yield ] unit-test
|
||||
|
||||
[ t ] [ walker get-tool walker-active? ] unit-test
|
||||
] with-scope
|
||||
|
|
|
|||
|
|
@ -65,7 +65,9 @@ M: walker call-tool* ( continuation walker -- )
|
|||
] if ;
|
||||
|
||||
: com-continue ( walker -- )
|
||||
dup walker-interpreter step-all reset-walker ;
|
||||
#! Reset walker first, in case step-all ends up calling
|
||||
#! the walker again.
|
||||
dup walker-interpreter swap reset-walker step-all ;
|
||||
|
||||
: walker-help "ui-walker" help-window ;
|
||||
|
||||
|
|
|
|||
|
|
@ -456,7 +456,7 @@ M: windows-ui-backend ui
|
|||
init-win32-ui
|
||||
start-ui
|
||||
event-loop
|
||||
] [ cleanup-win32-ui ] cleanup
|
||||
] [ cleanup-win32-ui ] [ ] cleanup
|
||||
] ui-running ;
|
||||
|
||||
T{ windows-ui-backend } ui-backend set-global
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
USING: kernel math tools.test units.imperial ;
|
||||
USING: kernel math tools.test units.imperial inverse ;
|
||||
IN: temporary
|
||||
|
||||
[ 1 ] [ 12 inches [ feet ] undo ] unit-test
|
||||
|
|
|
|||
|
|
@ -1,4 +1,5 @@
|
|||
USING: kernel tools.test units.si inverse ;
|
||||
USING: kernel tools.test units.si inverse math.constants
|
||||
math.functions units.imperial ;
|
||||
IN: temporary
|
||||
|
||||
[ t ] [ 1 m 100 cm = ] unit-test
|
||||
|
|
|
|||
|
|
@ -1,4 +1,5 @@
|
|||
USING: arrays kernel math sequences tools.test units.si units ;
|
||||
USING: arrays kernel math sequences tools.test units.si
|
||||
units.imperial units inverse math.functions ;
|
||||
IN: temporary
|
||||
|
||||
[ T{ dimensioned f 3 { m } { } } ] [ 3 m ] unit-test
|
||||
|
|
|
|||
|
|
@ -5,7 +5,7 @@ set +e
|
|||
|
||||
# Case insensitive string comparison
|
||||
shopt -s nocaseglob
|
||||
shopt -s nocasematch
|
||||
#shopt -s nocasematch
|
||||
|
||||
ensure_program_installed() {
|
||||
echo -n "Checking for $1..."
|
||||
|
|
@ -47,7 +47,9 @@ case $uname_s in
|
|||
*CYGWIN_NT*) OS=windows-nt;;
|
||||
*CYGWIN*) OS=windows-nt;;
|
||||
*darwin*) OS=macosx;;
|
||||
*Darwin*) OS=macosx;;
|
||||
*linux*) OS=linux;;
|
||||
*Linux*) OS=linux;;
|
||||
esac
|
||||
|
||||
# Architecture
|
||||
|
|
@ -107,4 +109,12 @@ rm $BOOT_IMAGE.* > /dev/null 2>&1
|
|||
wget http://factorcode.org/images/latest/$BOOT_IMAGE
|
||||
check_ret wget
|
||||
|
||||
if [[ $OS == windows-nt ]] ; then
|
||||
wget http://factorcode.org/dlls/freetype6.dll
|
||||
check_ret
|
||||
wget http://factorcode.org/dlls/zlib1.dla
|
||||
check_ret
|
||||
fi
|
||||
|
||||
|
||||
./$FACTOR_BINARY -i=$BOOT_IMAGE
|
||||
|
|
|
|||
|
|
@ -1,3 +1,7 @@
|
|||
#ifndef DEBUG
|
||||
CFLAGS += -fomit-frame-pointer
|
||||
#endif
|
||||
|
||||
EXE_SUFFIX =
|
||||
DLL_PREFIX = lib
|
||||
DLL_EXTENSION = .a
|
||||
|
|
|
|||
|
|
@ -6,6 +6,11 @@ F_FASTCALL void save_callstack_bottom(F_STACK_FRAME *callstack_bottom)
|
|||
stack_chain->callstack_bottom = callstack_bottom;
|
||||
}
|
||||
|
||||
F_FASTCALL __attribute__((noinline)) void save_callstack_top(F_STACK_FRAME *callstack_top)
|
||||
{
|
||||
stack_chain->callstack_top = callstack_top;
|
||||
}
|
||||
|
||||
void iterate_callstack(CELL top, CELL bottom, CALLSTACK_ITER iterator)
|
||||
{
|
||||
F_STACK_FRAME *frame = (F_STACK_FRAME *)bottom - 1;
|
||||
|
|
@ -35,6 +40,16 @@ F_CALLSTACK *allot_callstack(CELL size)
|
|||
return callstack;
|
||||
}
|
||||
|
||||
F_STACK_FRAME *fix_callstack_top(F_STACK_FRAME *top, F_STACK_FRAME *bottom)
|
||||
{
|
||||
F_STACK_FRAME *frame = bottom - 1;
|
||||
|
||||
while(frame >= top)
|
||||
frame = frame_successor(frame);
|
||||
|
||||
return frame + 1;
|
||||
}
|
||||
|
||||
/* We ignore the topmost frame, the one calling 'callstack',
|
||||
so that set-callstack doesn't get stuck in an infinite loop.
|
||||
|
||||
|
|
|
|||
|
|
@ -1,13 +1,16 @@
|
|||
F_FASTCALL void save_callstack_bottom(F_STACK_FRAME *callstack_bottom);
|
||||
F_FASTCALL __attribute__((noinline)) void save_callstack_top(F_STACK_FRAME *callstack_top);
|
||||
|
||||
#define FIRST_STACK_FRAME(stack) (F_STACK_FRAME *)((stack) + 1)
|
||||
|
||||
typedef void (*CALLSTACK_ITER)(F_STACK_FRAME *frame);
|
||||
|
||||
F_STACK_FRAME *fix_callstack_top(F_STACK_FRAME *top, F_STACK_FRAME *bottom);
|
||||
void iterate_callstack(CELL top, CELL bottom, CALLSTACK_ITER iterator);
|
||||
void iterate_callstack_object(F_CALLSTACK *stack, CALLSTACK_ITER iterator);
|
||||
F_STACK_FRAME *frame_successor(F_STACK_FRAME *frame);
|
||||
CELL frame_executing(F_STACK_FRAME *frame);
|
||||
CELL frame_scan(F_STACK_FRAME *frame);
|
||||
CELL frame_type(F_STACK_FRAME *frame);
|
||||
|
||||
DECLARE_PRIMITIVE(callstack);
|
||||
|
|
|
|||
|
|
@ -63,3 +63,8 @@ DEF(FASTCALL void,lazy_jit_compile,(CELL quot)):
|
|||
pop XT_REG
|
||||
pop XT_REG
|
||||
JUMP_QUOT /* Call the quotation */
|
||||
|
||||
#ifdef WINDOWS
|
||||
.section .drectve
|
||||
.ascii " -export:c_to_factor"
|
||||
#endif
|
||||
|
|
|
|||
|
|
@ -102,6 +102,8 @@ void print_stack_frame(F_STACK_FRAME *frame)
|
|||
{
|
||||
print_obj(frame_executing(frame));
|
||||
printf("\n");
|
||||
print_obj(frame_scan(frame));
|
||||
printf("\n");
|
||||
}
|
||||
|
||||
void print_callstack(void)
|
||||
|
|
|
|||
13
vm/errors.c
13
vm/errors.c
|
|
@ -35,7 +35,12 @@ void throw_error(CELL error, F_STACK_FRAME *callstack_top)
|
|||
Errors thrown from Factor code, or signal handlers, pass the
|
||||
actual stack pointer at the time, since the saved pointer is
|
||||
not necessarily up to date at that point. */
|
||||
if(!callstack_top)
|
||||
if(callstack_top)
|
||||
{
|
||||
callstack_top = fix_callstack_top(callstack_top,
|
||||
stack_chain->callstack_bottom);
|
||||
}
|
||||
else
|
||||
callstack_top = stack_chain->callstack_top;
|
||||
|
||||
throw_impl(userenv[BREAK_ENV],callstack_top);
|
||||
|
|
@ -137,3 +142,9 @@ DEFINE_PRIMITIVE(throw)
|
|||
uncurry(dpop());
|
||||
throw_impl(dpop(),stack_chain->callstack_top);
|
||||
}
|
||||
|
||||
DEFINE_PRIMITIVE(call_clear)
|
||||
{
|
||||
uncurry(dpop());
|
||||
throw_impl(dpop(),stack_chain->callstack_bottom);
|
||||
}
|
||||
|
|
|
|||
|
|
@ -35,6 +35,7 @@ void not_implemented_error(void);
|
|||
F_FASTCALL void undefined_error(CELL word, F_STACK_FRAME *callstack_top);
|
||||
|
||||
DECLARE_PRIMITIVE(throw);
|
||||
DECLARE_PRIMITIVE(call_clear);
|
||||
|
||||
INLINE void type_check(CELL type, CELL tagged)
|
||||
{
|
||||
|
|
|
|||
|
|
@ -29,7 +29,7 @@ long exception_handler(PEXCEPTION_POINTERS pe)
|
|||
CONTEXT *c = (CONTEXT*)pe->ContextRecord;
|
||||
|
||||
if(in_code_heap_p(c->Eip))
|
||||
signal_callstack_top = (void*)c->Esp;
|
||||
signal_callstack_top = (void *)c->Esp;
|
||||
else
|
||||
signal_callstack_top = NULL;
|
||||
|
||||
|
|
|
|||
|
|
@ -193,4 +193,5 @@ void *primitives[] = {
|
|||
primitive_innermost_stack_frame_quot,
|
||||
primitive_innermost_stack_frame_scan,
|
||||
primitive_set_innermost_stack_frame_quot,
|
||||
primitive_call_clear,
|
||||
};
|
||||
|
|
|
|||
|
|
@ -16,19 +16,22 @@ Becomes
|
|||
|
||||
F_FASTCALL void primitive_name(CELL word, F_STACK_FRAME *callstack_top)
|
||||
{
|
||||
stack_chain->callstack_top = callstack_top;
|
||||
save_callstack_top(callstack_top);
|
||||
... CODE ...
|
||||
}
|
||||
|
||||
On x86, F_FASTCALL expands into a GCC declaration which forces the two
|
||||
parameters to be passed in registers. This simplifies the quotation compiler
|
||||
and support code in cpu-x86.S. */
|
||||
and support code in cpu-x86.S.
|
||||
|
||||
We do the assignment of stack_chain->callstack_top in a ``noinline'' function
|
||||
to inhibit assignment re-ordering. */
|
||||
#define DEFINE_PRIMITIVE(name) \
|
||||
INLINE void primitive_##name##_impl(void); \
|
||||
\
|
||||
F_FASTCALL void primitive_##name(CELL word, F_STACK_FRAME *callstack_top) \
|
||||
{ \
|
||||
stack_chain->callstack_top = callstack_top; \
|
||||
save_callstack_top(callstack_top); \
|
||||
primitive_##name##_impl(); \
|
||||
} \
|
||||
\
|
||||
|
|
|
|||
Loading…
Reference in New Issue