PRIVATE>
-: indirect-quot ( function-ptr-quot return types abi -- quot )
- [ alien-indirect ] 3curry compose ;
-
-: define-indirect ( abi return function-ptr-quot function-name parameters -- )
- [ pick ] dip parse-arglist
- rot create-in dup reset-generic
- [ swapd roll indirect-quot ] dip
- -rot define-declared ;
-
: DLL" lexer get skip-blank parse-string dlopen parsed ; parsing
: ALIEN: scan string>number <alien> parsed ; parsing
parser prettyprint prettyprint.sections quotations sequences
strings words cocoa.runtime io macros memoize debugger
io.encodings.ascii effects libc libc.private parser lexer init
-core-foundation fry ;
+core-foundation fry generalizations ;
IN: cocoa.messages
: make-sender ( method function -- quot )
dup objc-methods get at
[ ] [ "No such method: " prepend throw ] ?if ;
-: make-dip ( quot n -- quot' )
- dup
- \ >r <repetition> >quotation -rot
- \ r> <repetition> >quotation 3append ;
-
MEMO: make-prepare-send ( selector method super? -- quot )
[
[ \ <super> , ] when
swap <selector> , \ selector ,
] [ ] make
- swap second length 2 - make-dip ;
+ swap second length 2 - '[ _ _ ndip ] ;
MACRO: (send) ( selector super? -- quot )
[ dup lookup-method ] dip
[ make-prepare-send ] 2keep
super-message-senders message-senders ? get at
- [ slip execute ] 2curry ;
+ '[ _ call _ execute ] ;
: send ( receiver args... selector -- return... ) f (send) ; inline
] unless ;
: (parse-objc-type) ( i string -- ctype )
- 2dup nth [ 1+ ] 2dip {
+ [ [ 1+ ] dip ] [ nth ] 2bi {
{ [ dup "rnNoORV" member? ] [ drop (parse-objc-type) ] }
{ [ dup CHAR: ^ = ] [ 3drop "void*" ] }
{ [ dup CHAR: { = ] [ drop objc-struct-type ] }
: import-objc-class ( name quot -- )
2dup unless-defined
dupd define-objc-class-word
- [
+ '[
+ _
dup
objc-class register-objc-methods
objc-meta-class register-objc-methods
- ] curry try ;
+ ] try ;
: root-class ( class -- root )
dup class_getSuperclass [ root-class ] [ ] ?if ;
M: ##compare defs-vregs dst/tmp-vregs ;
M: ##compare-imm defs-vregs dst/tmp-vregs ;
M: ##compare-float defs-vregs dst/tmp-vregs ;
+M: ##fixnum-mul defs-vregs [ temp1>> ] [ temp2>> ] bi 2array ;
+M: ##fixnum-mul-tail defs-vregs [ temp1>> ] [ temp2>> ] bi 2array ;
M: insn defs-vregs drop f ;
M: ##unary uses-vregs src>> 1array ;
INSN: ##fixnum-add-tail < ##fixnum-overflow ;
INSN: ##fixnum-sub < ##fixnum-overflow ;
INSN: ##fixnum-sub-tail < ##fixnum-overflow ;
-INSN: ##fixnum-mul < ##fixnum-overflow ;
-INSN: ##fixnum-mul-tail < ##fixnum-overflow ;
+INSN: ##fixnum-mul < ##fixnum-overflow temp1 temp2 ;
+INSN: ##fixnum-mul-tail < ##fixnum-overflow temp1 temp2 ;
: ##tag-fixnum ( dst src -- ) tag-bits get ##shl-imm ; inline
: ##untag-fixnum ( dst src -- ) tag-bits get ##sar-imm ; inline
math.private:both-fixnums?
math.private:fixnum+
math.private:fixnum-
+ math.private:fixnum*
math.private:fixnum+fast
math.private:fixnum-fast
math.private:fixnum-bitand
alien.accessors:set-alien-double
} [ t "intrinsic" set-word-prop ] each ;
-: enable-fixnum*-intrinsic ( -- )
- \ math.private:fixnum* t "intrinsic" set-word-prop ;
-
: emit-intrinsic ( node word -- node/f )
{
{ \ kernel.private:tag [ drop emit-tag iterate-next ] }
{ \ math.private:both-fixnums? [ drop emit-both-fixnums? iterate-next ] }
{ \ math.private:fixnum+ [ drop [ ##fixnum-add ] [ ##fixnum-add-tail ] emit-fixnum-overflow-op ] }
{ \ math.private:fixnum- [ drop [ ##fixnum-sub ] [ ##fixnum-sub-tail ] emit-fixnum-overflow-op ] }
- { \ math.private:fixnum* [ drop [ ##fixnum-mul ] [ ##fixnum-mul-tail ] emit-fixnum-overflow-op ] }
+ { \ math.private:fixnum* [ drop [ i i ##fixnum-mul ] [ i i ##fixnum-mul-tail ] emit-fixnum-overflow-op ] }
{ \ math.private:fixnum+fast [ [ ^^add ] [ ^^add-imm ] emit-fixnum-op iterate-next ] }
{ \ math.private:fixnum-fast [ [ ^^sub ] [ ^^sub-imm ] emit-fixnum-op iterate-next ] }
{ \ math.private:fixnum-bitand [ [ ^^and ] [ ^^and-imm ] emit-fixnum-op iterate-next ] }
: src1/src2 ( insn -- src1 src2 )
[ src1>> register ] [ src2>> register ] bi ; inline
+: src1/src2/temp1/temp2 ( insn -- src1 src2 temp1 temp2 )
+ [ src1/src2 ] [ temp1>> register ] [ temp2>> register ] tri ; inline
+
M: ##fixnum-add generate-insn src1/src2 %fixnum-add ;
M: ##fixnum-add-tail generate-insn src1/src2 %fixnum-add-tail ;
M: ##fixnum-sub generate-insn src1/src2 %fixnum-sub ;
M: ##fixnum-sub-tail generate-insn src1/src2 %fixnum-sub-tail ;
-M: ##fixnum-mul generate-insn src1/src2 %fixnum-mul ;
-M: ##fixnum-mul-tail generate-insn src1/src2 %fixnum-mul-tail ;
+M: ##fixnum-mul generate-insn src1/src2/temp1/temp2 %fixnum-mul ;
+M: ##fixnum-mul-tail generate-insn src1/src2/temp1/temp2 %fixnum-mul-tail ;
: dst/src/temp ( insn -- dst src temp )
[ dst/src ] [ temp>> register ] bi ; inline
[ -1 ] [ [ -123 -64 fixnum-shift ] compile-call ] unit-test
[ -1 ] [ -123 -64 [ fixnum-shift ] compile-call ] unit-test
+[ HEX: 10000000 ] [ HEX: 1000000 HEX: 10 [ fixnum* ] compile-call ] unit-test
[ HEX: 10000000 ] [ HEX: -10000000 >fixnum [ 0 swap fixnum- ] compile-call ] unit-test
[ HEX: 10000000 ] [ HEX: -fffffff >fixnum [ 1 swap fixnum- ] compile-call ] unit-test
HOOK: %fixnum-add-tail cpu ( src1 src2 -- )
HOOK: %fixnum-sub cpu ( src1 src2 -- )
HOOK: %fixnum-sub-tail cpu ( src1 src2 -- )
-HOOK: %fixnum-mul cpu ( src1 src2 -- )
-HOOK: %fixnum-mul-tail cpu ( src1 src2 -- )
+HOOK: %fixnum-mul cpu ( src1 src2 temp1 temp2 -- )
+HOOK: %fixnum-mul-tail cpu ( src1 src2 temp1 temp2 -- )
HOOK: %integer>bignum cpu ( dst src temp -- )
HOOK: %bignum>integer cpu ( dst src temp -- )
! f30, f31: float scratch
enable-float-intrinsics
-enable-fixnum*-intrinsic
<< \ ##integer>float t frame-required? set-word-prop
\ ##float>integer t frame-required? set-word-prop >>
[ 3 src1 MR 4 src2 MR ]
} cond ;
+: clear-xer ( -- )
+ 0 0 LI
+ 0 MTXER ; inline
+
:: overflow-template ( src1 src2 insn func -- )
"no-overflow" define-label
- 0 0 LI
- 0 MTXER
+ clear-xer
scratch-reg src2 src1 insn call
scratch-reg ds-reg 0 STW
"no-overflow" get BNO
- src2 src1 move>args
+ src1 src2 move>args
%prepare-alien-invoke
func f %alien-invoke
"no-overflow" resolve-label ; inline
:: overflow-template-tail ( src1 src2 insn func -- )
"overflow" define-label
- 0 0 LI
- 0 MTXER
+ clear-xer
scratch-reg src2 src1 insn call
"overflow" get BO
scratch-reg ds-reg 0 STW
BLR
"overflow" resolve-label
- src2 src1 move>args
+ src1 src2 move>args
%prepare-alien-invoke
func f %alien-invoke-tail ;
M: ppc %fixnum-sub-tail ( src1 src2 -- )
[ SUBFO. ] "overflow_fixnum_subtract" overflow-template-tail ;
-M:: ppc %fixnum-mul ( src1 src2 -- )
+M:: ppc %fixnum-mul ( src1 src2 temp1 temp2 -- )
"no-overflow" define-label
- 0 0 LI
- 0 MTXER
- scratch-reg src1 tag-bits get SRAWI
- scratch-reg scratch-reg src2 MULLWO.
- scratch-reg ds-reg 0 STW
+ clear-xer
+ temp1 src1 tag-bits get SRAWI
+ temp2 temp1 src2 MULLWO.
+ temp2 ds-reg 0 STW
"no-overflow" get BNO
src2 src2 tag-bits get SRAWI
- scratch-reg src2 move>args
+ temp1 src2 move>args
%prepare-alien-invoke
"overflow_fixnum_multiply" f %alien-invoke
"no-overflow" resolve-label ;
-M:: ppc %fixnum-mul-tail ( src1 src2 -- )
+M:: ppc %fixnum-mul-tail ( src1 src2 temp1 temp2 -- )
"overflow" define-label
- 0 0 LI
- 0 MTXER
- scratch-reg src1 tag-bits get SRAWI
- scratch-reg scratch-reg src2 MULLWO.
+ clear-xer
+ temp1 src1 tag-bits get SRAWI
+ temp2 temp1 src2 MULLWO.
"overflow" get BO
- scratch-reg ds-reg 0 STW
+ temp2 ds-reg 0 STW
BLR
"overflow" resolve-label
src2 src2 tag-bits get SRAWI
- scratch-reg src2 move>args
+ temp1 src2 move>args
%prepare-alien-invoke
"overflow_fixnum_multiply" f %alien-invoke-tail ;
M: x86.64 ds-reg R14 ;
M: x86.64 rs-reg R15 ;
M: x86.64 stack-reg RSP ;
-M: x86.64 temp-reg-1 R8 ;
-M: x86.64 temp-reg-2 R9 ;
M:: x86.64 %dispatch ( src temp offset -- )
! Load jump table base.
M: x86.64 dummy-int-params? f ;
M: x86.64 dummy-fp-params? f ;
+
+M: x86.64 temp-reg-1 R8 ;
+
+M: x86.64 temp-reg-2 R9 ;
M: x86.64 dummy-fp-params? t ;
+M: x86.64 temp-reg-1 RAX ;
+
+M: x86.64 temp-reg-2 RCX ;
+
<<
"longlong" "ptrdiff_t" typedef
"longlong" "intptr_t" typedef
M: x86 %fixnum-sub-tail ( src1 src2 -- )
[ SUB ] [ ADD ] "overflow_fixnum_subtract" overflow-template-tail ;
+M:: x86 %fixnum-mul ( src1 src2 temp1 temp2 -- )
+ "no-overflow" define-label
+ temp1 src1 MOV
+ temp1 tag-bits get SAR
+ src2 temp1 IMUL2
+ ds-reg [] temp1 MOV
+ "no-overflow" get JNO
+ src1 src2 move>args
+ param-reg-1 tag-bits get SAR
+ param-reg-2 tag-bits get SAR
+ %prepare-alien-invoke
+ "overflow_fixnum_multiply" f %alien-invoke
+ "no-overflow" resolve-label ;
+
+M:: x86 %fixnum-mul-tail ( src1 src2 temp1 temp2 -- )
+ "overflow" define-label
+ temp1 src1 MOV
+ temp1 tag-bits get SAR
+ src2 temp1 IMUL2
+ "overflow" get JO
+ ds-reg [] temp1 MOV
+ 0 RET
+ "overflow" resolve-label
+ src1 src2 move>args
+ param-reg-1 tag-bits get SAR
+ param-reg-2 tag-bits get SAR
+ %prepare-alien-invoke
+ "overflow_fixnum_multiply" f %alien-invoke-tail ;
+
: bignum@ ( reg n -- op )
cells bignum tag-number - [+] ; inline
: create-index ( index-name table-name columns -- )
[
- [ [ "create index " % % ] dip " on " % % ] 2dip "(" %
+ [ [ "create index " % % ] dip " on " % % ] dip "(" %
"," join % ")" %
] "" make sql-command ;
dup clone 3 over push-back
[ dlist>seq ] bi@
] unit-test
+
+[ V{ f 3 1 f } ] [ <dlist> 1 over push-front 3 over push-front f over push-front f over push-back dlist>seq ] unit-test
+
+[ V{ } ] [ <dlist> dlist>seq ] unit-test
[ obj>> ] prepose dlist-each-node ; inline
: dlist>seq ( dlist -- seq )
- [ ] pusher [ dlist-each ] dip ;
+ [ ] accumulator [ dlist-each ] dip ;
: 1dlist ( obj -- dlist ) <dlist> [ push-front ] keep ;
: <hash2> ( size -- hash2 ) f <array> ;
: 2= ( a b pair -- ? )
- first2 swapd [ = ] 2dip = and ; inline
+ first2 swapd [ = ] 2bi@ and ; inline
: (assoc2) ( a b alist -- {a,b,val} )
- [ [ 2dup ] dip 2= ] find [ 3drop ] dip ; inline
+ [ 2= ] with with find nip ; inline
: assoc2 ( a b alist -- value )
(assoc2) dup [ third ] when ; inline
[ 2dup hashcode2 ] dip [ length mod ] keep ; inline
: hash2 ( a b hash2 -- value/f )
- hash2@ nth [ assoc2 ] [ 2drop f ] if* ;
+ hash2@ nth dup [ assoc2 ] [ 3drop f ] if ;
: set-hash2 ( a b value hash2 -- )
[ -rot ] dip hash2@ [ set-assoc2 ] change-nth ;
[ 2dup assoc>> key? [ 2dup delete-at ] when add-to-dlist ] 2keep
assoc>> set-at ;
-: dlist>seq ( dlist -- seq )
- [ ] pusher [ dlist-each ] dip ;
-
M: linked-assoc >alist
dlist>> dlist>seq ;
[ f ] [ \ number= fixnum object math-both-known? ] unit-test
[ t ] [ \ number= integer fixnum math-both-known? ] unit-test
[ f ] [ \ >fixnum \ shift derived-ops memq? ] unit-test
+[ f ] [ \ >integer \ /i derived-ops memq? ] unit-test
+[ t ] [ \ fixnum-shift \ shift derived-ops memq? ] unit-test
[ { integer fixnum } ] [ \ +-integer-fixnum integer-op-input-classes ] unit-test
[ { fixnum fixnum } ] [ \ fixnum+ integer-op-input-classes ] unit-test
[ fixnum-bitnot ] [ \ bitnot modular-variant ] unit-test
[ fixnum+fast ] [ \ fixnum+ modular-variant ] unit-test
[ fixnum+fast ] [ \ fixnum+fast modular-variant ] unit-test
-
: integer-derived-ops ( word -- words )
[ math-ops get (derived-ops) ] [ fast-math-ops get (derived-ops) ] bi
[
- [
+ [
drop
[ second integer class<= ]
[ third integer class<= ]
\ + define-math-ops
\ - define-math-ops
\ * define-math-ops
- \ shift define-math-ops
\ mod define-math-ops
\ /i define-math-ops
\ >= define-math-ops
\ number= define-math-ops
+ { { shift bignum bignum } bignum-shift } ,
+ { { shift fixnum fixnum } fixnum-shift } ,
+
\ + \ fixnum+ \ bignum+ define-integer-ops
\ - \ fixnum- \ bignum- define-integer-ops
\ * \ fixnum* \ bignum* define-integer-ops
-USING: alien alien.syntax combinators kernel parser sequences
-system words namespaces hashtables init math arrays assocs
-continuations lexer ;
+USING: alien alien.syntax alien.syntax.private combinators
+kernel parser sequences system words namespaces hashtables init
+math arrays assocs continuations lexer ;
IN: opengl.gl.extensions
ERROR: unknown-gl-platform ;
+gl-function-pointers+ get-global set-at
] if* ;
+: indirect-quot ( function-ptr-quot return types abi -- quot )
+ [ alien-indirect ] 3curry compose ;
+
+: define-indirect ( abi return function-ptr-quot function-name parameters -- )
+ [ pick ] dip parse-arglist
+ rot create-in
+ [ swapd roll indirect-quot ] 2dip
+ -rot define-declared ;
+
: GL-FUNCTION:
gl-function-calling-convention
scan
[ first ] [ ] bi exec-with-path ;
: exec-args-with-env ( seq seq -- int )
- >r [ first ] [ ] bi r> exec-with-env ;
+ [ [ first ] [ ] bi ] dip exec-with-env ;
: with-fork ( child parent -- )
[ [ fork-process dup zero? ] dip [ drop ] prepose ] dip
{ "uid_t" "f_owner" }
{ { "uint32_t" 4 } "f_spare" }
{ { "char" _VFS_NAMELEN } "f_fstypename" }
- { { "char" _VFS_NAMELEN } "f_mntonname" }
- { { "char" _VFS_NAMELEN } "f_mntfromname" } ;
+ { { "char" _VFS_MNAMELEN } "f_mntonname" }
+ { { "char" _VFS_MNAMELEN } "f_mntfromname" } ;
FUNCTION: int statvfs ( char* path, statvfs *buf ) ;
: PATH_MAX 1024 ; inline
: read-symbolic-link ( path -- path )
- PATH_MAX <byte-array> dup >r
- PATH_MAX
- [ readlink ] unix-system-call
- r> swap head-slice >string ;
+ PATH_MAX <byte-array> dup [
+ PATH_MAX
+ [ readlink ] unix-system-call
+ ] dip swap head-slice >string ;
FUNCTION: ssize_t recv ( int s, void* buf, size_t nbytes, int flags ) ;
FUNCTION: ssize_t recvfrom ( int s, void* buf, size_t nbytes, int flags, sockaddr-in* from, socklen_t* fromlen ) ;
: <no-word-error> ( name possibilities -- error restarts )
[ drop \ no-word-error boa ] [ word-restarts ] 2bi ;
-SYMBOL: amended-use?
+SYMBOL: amended-use
SYMBOL: auto-use?
: no-word-restarted ( restart-value -- word )
dup word? [
- amended-use? on
dup vocabulary>>
- [ (use+) ] [
- "Added ``" swap "'' vocabulary to search path" 3append note.
- ] bi
+ [ (use+) ]
+ [ amended-use get dup [ push ] [ 2drop ] if ]
+ [ "Added ``" swap "'' vocabulary to search path" 3append note. ]
+ tri
] [ create-in ] if ;
: no-word ( name -- newword )
SYMBOL: print-use-hook
print-use-hook global [ [ ] or ] change-at
-
+!
: parse-fresh ( lines -- quot )
[
- amended-use? off
+ V{ } clone amended-use set
parse-lines
- amended-use? get [
- print-use-hook get call
- ] when
+ amended-use get empty? [ print-use-hook get call ] unless
] with-file-vocabs ;
: parsing-file ( file -- )
- "quiet" get [
- drop
- ] [
- "Loading " write print flush
- ] if ;
+ "quiet" get [ drop ] [ "Loading " write print flush ] if ;
: filter-moved ( assoc1 assoc2 -- seq )
swap assoc-diff [
math.order
math.vectors
math.trig
- math.physics.pos
- math.physics.vel
+ math.ranges
combinators arrays sequences random vars
combinators.lib
combinators.short-circuit
- accessors ;
+ accessors
+ flatland ;
IN: boids
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-TUPLE: boid < vel ;
+TUPLE: boid < <vel> ;
C: <boid> boid
! random-boid and random-boids
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-: random-range ( a b -- n ) 1+ over - random + ;
-
: random-pos ( -- pos ) world-size> [ random ] map ;
-: random-vel ( -- vel ) 2 [ drop -10 10 random-range ] map ;
+: random-vel ( -- vel ) 2 [ drop -10 10 [a,b] random ] map ;
: random-boid ( -- boid ) random-pos random-vel <boid> ;
--- /dev/null
+
+USING: combinators.cleave fry kernel macros parser quotations ;
+
+IN: combinators.cleave.enhanced
+
+: \\
+ scan-word literalize parsed
+ scan-word literalize parsed ; parsing
+
+MACRO: bi ( p q -- quot )
+ [ >quot ] dip
+ >quot
+ '[ _ _ [ keep ] dip call ] ;
+
+MACRO: tri ( p q r -- quot )
+ [ >quot ] 2dip
+ [ >quot ] dip
+ >quot
+ '[ _ _ _ [ [ keep ] dip keep ] dip call ] ;
+
+MACRO: bi* ( p q -- quot )
+ [ >quot ] dip
+ >quot
+ '[ _ _ [ dip ] dip call ] ;
+
+MACRO: tri* ( p q r -- quot )
+ [ >quot ] 2dip
+ [ >quot ] dip
+ >quot
+ '[ _ _ _ [ [ 2dip ] dip dip ] dip call ] ;
+
--- /dev/null
+
+USING: accessors arrays fry kernel math math.vectors sequences
+ math.intervals
+ multi-methods
+ combinators.cleave.enhanced
+ multi-method-syntax ;
+
+IN: flatland
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! Two dimensional world protocol
+
+GENERIC: x ( obj -- x )
+GENERIC: y ( obj -- y )
+
+GENERIC: (x!) ( x obj -- )
+GENERIC: (y!) ( y obj -- )
+
+: x! ( obj x -- obj ) over (x!) ;
+: y! ( obj y -- obj ) over (y!) ;
+
+GENERIC: width ( obj -- width )
+GENERIC: height ( obj -- height )
+
+GENERIC: (width!) ( width obj -- )
+GENERIC: (height!) ( height obj -- )
+
+: width! ( obj width -- obj ) over (width!) ;
+: height! ( obj height -- obj ) over (width!) ;
+
+! Predicates on relative placement
+
+GENERIC: to-the-left-of? ( obj obj -- ? )
+GENERIC: to-the-right-of? ( obj obj -- ? )
+
+GENERIC: below? ( obj obj -- ? )
+GENERIC: above? ( obj obj -- ? )
+
+GENERIC: in-between-horizontally? ( obj obj -- ? )
+
+GENERIC: horizontal-interval ( obj -- interval )
+
+GENERIC: move-to ( obj obj -- )
+
+GENERIC: move-by ( obj delta -- )
+
+GENERIC: move-left-by ( obj obj -- )
+GENERIC: move-right-by ( obj obj -- )
+
+GENERIC: left ( obj -- left )
+GENERIC: right ( obj -- right )
+GENERIC: bottom ( obj -- bottom )
+GENERIC: top ( obj -- top )
+
+GENERIC: distance ( a b -- c )
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! Some of the above methods work on two element sequences.
+! A two element sequence may represent a point in space or describe
+! width and height.
+
+METHOD: x ( sequence -- x ) first ;
+METHOD: y ( sequence -- y ) second ;
+
+METHOD: (x!) ( number sequence -- ) set-first ;
+METHOD: (y!) ( number sequence -- ) set-second ;
+
+METHOD: width ( sequence -- width ) first ;
+METHOD: height ( sequence -- height ) second ;
+
+: changed-x ( seq quot -- ) over [ [ x ] dip call ] dip (x!) ; inline
+: changed-y ( seq quot -- ) over [ [ y ] dip call ] dip (y!) ; inline
+
+METHOD: move-to ( sequence sequence -- ) [ x x! ] [ y y! ] bi drop ;
+METHOD: move-by ( sequence sequence -- ) dupd v+ [ x x! ] [ y y! ] bi drop ;
+
+METHOD: move-left-by ( sequence number -- ) '[ _ - ] changed-x ;
+METHOD: move-right-by ( sequence number -- ) '[ _ + ] changed-x ;
+
+! METHOD: move-left-by ( sequence number -- ) neg 0 2array move-by ;
+! METHOD: move-right-by ( sequence number -- ) 0 2array move-by ;
+
+! METHOD:: move-left-by ( SEQ:sequence X:number -- )
+! SEQ { X 0 } { -1 0 } v* move-by ;
+
+METHOD: distance ( sequence sequence -- dist ) v- norm ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! A class for objects with a position
+
+TUPLE: <pos> pos ;
+
+METHOD: x ( <pos> -- x ) pos>> first ;
+METHOD: y ( <pos> -- y ) pos>> second ;
+
+METHOD: (x!) ( number <pos> -- ) pos>> set-first ;
+METHOD: (y!) ( number <pos> -- ) pos>> set-second ;
+
+METHOD: to-the-left-of? ( <pos> number -- ? ) [ x ] dip < ;
+METHOD: to-the-right-of? ( <pos> number -- ? ) [ x ] dip > ;
+
+METHOD: move-left-by ( <pos> number -- ) [ pos>> ] dip move-left-by ;
+METHOD: move-right-by ( <pos> number -- ) [ pos>> ] dip move-right-by ;
+
+METHOD: above? ( <pos> number -- ? ) [ y ] dip > ;
+METHOD: below? ( <pos> number -- ? ) [ y ] dip < ;
+
+METHOD: move-by ( <pos> sequence -- ) '[ _ v+ ] change-pos drop ;
+
+METHOD: distance ( <pos> <pos> -- dist ) [ pos>> ] bi@ distance ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! A class for objects with velocity. It inherits from <pos>. Hey, if
+! it's moving it has a position right? Unless it's some alternate universe...
+
+TUPLE: <vel> < <pos> vel ;
+
+: moving-up? ( obj -- ? ) vel>> y 0 > ;
+: moving-down? ( obj -- ? ) vel>> y 0 < ;
+
+: step-size ( vel time -- dist ) [ vel>> ] dip v*n ;
+: move-for ( vel time -- ) dupd step-size move-by ;
+
+: reverse-horizontal-velocity ( vel -- ) vel>> [ x neg ] [ ] bi (x!) ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! The 'pos' slot indicates the lower left hand corner of the
+! rectangle. The 'dim' is holds the width and height.
+
+TUPLE: <rectangle> < <pos> dim ;
+
+METHOD: width ( <rectangle> -- width ) dim>> first ;
+METHOD: height ( <rectangle> -- height ) dim>> second ;
+
+METHOD: left ( <rectangle> -- x ) x ;
+METHOD: right ( <rectangle> -- x ) \\ x width bi + ;
+METHOD: bottom ( <rectangle> -- y ) y ;
+METHOD: top ( <rectangle> -- y ) \\ y height bi + ;
+
+: bottom-left ( rectangle -- pos ) pos>> ;
+
+: center-x ( rectangle -- x ) [ left ] [ width 2 / ] bi + ;
+: center-y ( rectangle -- y ) [ bottom ] [ height 2 / ] bi + ;
+
+: center ( rectangle -- seq ) \\ center-x center-y bi 2array ;
+
+METHOD: to-the-left-of? ( <pos> <rectangle> -- ? ) \\ x left bi* < ;
+METHOD: to-the-right-of? ( <pos> <rectangle> -- ? ) \\ x right bi* > ;
+
+METHOD: below? ( <pos> <rectangle> -- ? ) \\ y bottom bi* < ;
+METHOD: above? ( <pos> <rectangle> -- ? ) \\ y top bi* > ;
+
+METHOD: horizontal-interval ( <rectangle> -- interval )
+ \\ left right bi [a,b] ;
+
+METHOD: in-between-horizontally? ( <pos> <rectangle> -- ? )
+ \\ x horizontal-interval bi* interval-contains? ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TUPLE: <extent> left right bottom top ;
+
+METHOD: left ( <extent> -- left ) left>> ;
+METHOD: right ( <extent> -- right ) right>> ;
+METHOD: bottom ( <extent> -- bottom ) bottom>> ;
+METHOD: top ( <extent> -- top ) top>> ;
+
+METHOD: width ( <extent> -- width ) \\ right>> left>> bi - ;
+METHOD: height ( <extent> -- height ) \\ top>> bottom>> bi - ;
+
+! METHOD: to-extent ( <rectangle> -- <extent> )
+! { [ left>> ] [ right>> ] [ bottom>> ] [ top>> ] } cleave <extent> boa ;
+
--- /dev/null
+
+USING: accessors effects.parser kernel lexer multi-methods
+ parser sequences words ;
+
+IN: multi-method-syntax
+
+! A nicer specializer syntax to hold us over till multi-methods go in
+! officially.
+!
+! Use both 'multi-methods' and 'multi-method-syntax' in that order.
+
+: scan-specializer ( -- specializer )
+
+ scan drop ! eat opening parenthesis
+
+ ")" parse-effect in>> [ search ] map ;
+
+: CREATE-METHOD ( -- method )
+ scan-word scan-specializer swap create-method-in ;
+
+: (METHOD:) ( -- method def ) CREATE-METHOD parse-definition ;
+
+: METHOD: (METHOD:) define ; parsing
\ No newline at end of file
--- /dev/null
+
+USING: kernel accessors locals math math.intervals math.order
+ namespaces sequences threads
+ ui
+ ui.gadgets
+ ui.gestures
+ ui.render
+ calendar
+ multi-methods
+ multi-method-syntax
+ combinators.short-circuit.smart
+ combinators.cleave.enhanced
+ processing.shapes
+ flatland ;
+
+IN: pong
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: clamp-to-interval ( x interval -- x )
+ [ from>> first max ] [ to>> first min ] bi ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TUPLE: <play-field> < <rectangle> ;
+TUPLE: <paddle> < <rectangle> ;
+
+TUPLE: <computer> < <paddle> { speed initial: 10 } ;
+
+: computer-move-left ( computer -- ) dup speed>> move-left-by ;
+: computer-move-right ( computer -- ) dup speed>> move-right-by ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TUPLE: <ball> < <vel>
+ { diameter initial: 20 }
+ { bounciness initial: 1.2 }
+ { max-speed initial: 10 } ;
+
+: above-lower-bound? ( ball field -- ? ) bottom 50 - above? ;
+: below-upper-bound? ( ball field -- ? ) top 50 + below? ;
+
+: in-bounds? ( ball field -- ? )
+ {
+ [ above-lower-bound? ]
+ [ below-upper-bound? ]
+ } && ;
+
+:: bounce-change-vertical-velocity ( BALL -- )
+
+ BALL vel>> y neg
+ BALL bounciness>> *
+
+ BALL max-speed>> min
+
+ BALL vel>> (y!) ;
+
+:: bounce-off-paddle ( BALL PADDLE -- )
+
+ BALL bounce-change-vertical-velocity
+
+ BALL x PADDLE center x - 0.25 * BALL vel>> (x!)
+
+ PADDLE top BALL pos>> (y!) ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: mouse-x ( -- x ) hand-loc get first ;
+
+:: valid-paddle-interval ( PADDLE PLAY-FIELD -- interval )
+
+ PLAY-FIELD [ left ] [ right ] bi PADDLE width - [a,b] ;
+
+:: align-paddle-with-mouse ( PADDLE PLAY-FIELD -- )
+
+ mouse-x
+
+ PADDLE PLAY-FIELD valid-paddle-interval
+
+ clamp-to-interval
+
+ PADDLE pos>> (x!) ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! Protocol for drawing PONG objects
+
+GENERIC: draw ( obj -- )
+
+METHOD: draw ( <paddle> -- ) [ bottom-left ] [ dim>> ] bi rectangle ;
+METHOD: draw ( <ball> -- ) [ pos>> ] [ diameter>> 2 / ] bi circle ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+USE: syntax ! Switch back to core 'TUPLE:' instead of the one provided
+ ! by multi-methods
+
+TUPLE: <pong> < gadget draw closed ;
+
+M: <pong> pref-dim* ( <pong> -- dim ) drop { 400 400 } ;
+M: <pong> draw-gadget* ( <pong> -- ) draw>> call ;
+M: <pong> ungraft* ( <pong> -- ) t >>closed drop ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: make-draw-closure ( -- closure )
+
+ ! Establish some bindings
+
+ [let | PLAY-FIELD [ T{ <play-field> { pos { 0 0 } } { dim { 400 400 } } } ]
+ BALL [ T{ <ball> { pos { 50 50 } } { vel { 3 4 } } } ]
+
+ PLAYER [ T{ <paddle> { pos { 200 396 } } { dim { 75 4 } } } ]
+ COMPUTER [ T{ <computer> { pos { 200 0 } } { dim { 75 4 } } } ] |
+
+ ! Define some internal words in terms of those bindings ...
+
+ [wlet | align-player-with-mouse [ ( -- )
+ PLAYER PLAY-FIELD align-paddle-with-mouse ]
+
+ move-ball [ ( -- ) BALL 1 move-for ]
+
+ player-blocked-ball? [ ( -- ? )
+ BALL PLAYER { [ above? ] [ in-between-horizontally? ] } && ]
+
+ computer-blocked-ball? [ ( -- ? )
+ BALL COMPUTER { [ below? ] [ in-between-horizontally? ] } && ]
+
+ bounce-off-wall? [ ( -- ? )
+ BALL PLAY-FIELD in-between-horizontally? not ] |
+
+ ! Note, we're returning a quotation.
+ ! The quotation closes over the bindings established by the 'let'.
+ ! Thus the name of the word 'make-draw-closure'.
+ ! This closure is intended to be placed in the 'draw' slot of a
+ ! <pong> gadget.
+
+ [
+
+ BALL PLAY-FIELD in-bounds?
+ [
+ align-player-with-mouse
+
+ move-ball
+
+ ! computer reaction
+
+ BALL COMPUTER to-the-left-of? [ COMPUTER computer-move-left ] when
+ BALL COMPUTER to-the-right-of? [ COMPUTER computer-move-right ] when
+
+ ! check if ball bounced off something
+
+ player-blocked-ball? [ BALL PLAYER bounce-off-paddle ] when
+ computer-blocked-ball? [ BALL COMPUTER bounce-off-paddle ] when
+ bounce-off-wall? [ BALL reverse-horizontal-velocity ] when
+
+ ! draw the objects
+
+ COMPUTER draw
+ PLAYER draw
+ BALL draw
+
+ ]
+ when
+
+ ] ] ] ( -- closure ) ; ! The trailing stack effect here is a workaround.
+ ! The stack effects in the wlet expression throw
+ ! off the effect for the whole word, so we reset
+ ! it to the correct one here.
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: pong-loop-step ( PONG -- ? )
+ PONG closed>>
+ [ f ]
+ [ PONG relayout-1 25 milliseconds sleep t ]
+ if ;
+
+:: start-pong-thread ( PONG -- ) [ [ PONG pong-loop-step ] loop ] in-thread ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: play-pong ( -- )
+
+ <pong> new-gadget
+ make-draw-closure >>draw
+ dup "PONG" open-window
+
+ start-pong-thread ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: play-pong-main ( -- ) [ play-pong ] with-ui ;
+
+MAIN: play-pong-main
\ No newline at end of file
"OCT:" "POSTPONE:" "PREDICATE:" "PRIMITIVE:" "PRIVATE>" "PROVIDE:"
"REQUIRE:" "REQUIRES:" "SINGLETON:" "SLOT:" "SYMBOL:" "SYMBOLS:"
"TUPLE:" "T{" "t\\??" "TYPEDEF:"
- "UNION:" "USE:" "USING:" "V{" "VAR:" "VARS:" "W{"))
+ "UNION:" "USE:" "USING:" "V{" "VARS:" "W{"))
(defconst factor--regex-parsing-words-ext
(regexp-opt '("B" "call-next-method" "delimiter" "f" "initial:" "read-only")
(defsubst factor--regex-second-word (prefixes)
(format "^%s +\\([^ \r\n]+\\)" (regexp-opt prefixes t)))
+(defconst factor--regex-method-definition
+ "^M: +\\([^ ]+\\) +\\([^ ]+\\)")
+
(defconst factor--regex-word-definition
- (factor--regex-second-word '(":" "::" "M:" "GENERIC:")))
+ (factor--regex-second-word '(":" "::" "GENERIC:")))
(defconst factor--regex-type-definition
- (factor--regex-second-word '("TUPLE:")))
+ (factor--regex-second-word '("TUPLE:" "SINGLETON:")))
(defconst factor--regex-parent-type "^TUPLE: +[^ ]+ +< +\\([^ ]+\\)")
(defconst factor--regex-setter "\\W>>[^ ]+\\b")
(defconst factor--regex-symbol-definition
- (factor--regex-second-word '("SYMBOL:")))
+ (factor--regex-second-word '("SYMBOL:" "VAR:")))
(defconst factor--regex-stack-effect " ( .* )")
(,factor--regex-declaration-words 1 'factor-font-lock-declaration)
(,factor--regex-word-definition 2 'factor-font-lock-word-definition)
(,factor--regex-type-definition 2 'factor-font-lock-type-definition)
+ (,factor--regex-method-definition (1 'factor-font-lock-type-definition)
+ (2 'factor-font-lock-word-definition))
(,factor--regex-parent-type 1 'factor-font-lock-type-definition)
(,factor--regex-constructor . 'factor-font-lock-constructor)
(,factor--regex-setter . 'factor-font-lock-setter-word)
(,factor--regex-symbol-definition 2 'factor-font-lock-symbol-definition)
- (,factor--regex-using-lines 1 'factor-font-lock-vocabulary-name)
(,factor--regex-use-line 1 'factor-font-lock-vocabulary-name))
"Font lock keywords definition for Factor mode.")
;;; Factor mode syntax:
(defconst factor--regex-definition-starters
- (regexp-opt '("TUPLE" "MACRO" "MACRO:" "M" ":" "")))
+ (regexp-opt '("VARS" "TUPLE" "MACRO" "MACRO:" "M" ":" "")))
(defconst factor--regex-definition-start
(format "^\\(%s:\\) " factor--regex-definition-starters))
(defconst factor--regex-single-liner
(format "^%s" (regexp-opt '("DEFER:" "GENERIC:" "IN:"
- "PRIVATE>" "<PRIVATE" "SYMBOL:" "USE:"))))
+ "PRIVATE>" "<PRIVATE"
+ "SINGLETON:" "SYMBOL:" "USE:" "VAR:"))))
(defconst factor--regex-begin-of-def
(format "^USING: \\|\\(%s\\)\\|\\(%s .*\\)"
(defvar factor-mode-map (make-sparse-keymap)
"Key map used by Factor mode.")
-(defsubst factor--beginning-of-defun (times)
+(defsubst factor--beginning-of-defun (&optional times)
(re-search-backward factor--regex-begin-of-def nil t times))
(defsubst factor--end-of-defun ()
b MANGLE(overflow_fixnum_add)
DEF(void,primitive_fixnum_subtract,(void)):
- lwz r3,0(DS_REG)
- lwz r4,-4(DS_REG)
+ lwz r3,-4(DS_REG)
+ lwz r4,0(DS_REG)
subi DS_REG,DS_REG,4
li r0,0
mtxer r0
- subfo. r5,r3,r4
+ subfo. r5,r4,r3
bso sub_overflow
stw r5,0(DS_REG)
blr
projects / factor.git / commitdiff