steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Clean up space invaders (untested)

db4
Slava Pestov 2008-02-16 02:21:45 -06:00
parent 9ffeaae63d
commit 63d89878d8
5 changed files with 75 additions and 97 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
extra/channels/examples/examples.factor Normal file → Executable file
View File

@ -24,7 +24,7 @@ IN: channels.examples
from swap dupd mod zero? not [ swap to ] [ 2drop ] if from swap dupd mod zero? not [ swap to ] [ 2drop ] if
] 3keep filter ; ] 3keep filter ;
:: (sieve) | prime c | :: (sieve) | prime c | ( prime c -- )
[let | p [ c from ] [let | p [ c from ]
newc [ <channel> ] | newc [ <channel> ] |
p prime to p prime to

29
extra/cpu/8080/8080.factor Normal file → Executable file
View File

@ -249,32 +249,3 @@ INSTRUCTION: EI ; opcode FB cycles 04
INSTRUCTION: CALL M,nn ; opcode FC cycles 11 INSTRUCTION: CALL M,nn ; opcode FC cycles 11
INSTRUCTION: CP n ; opcode FE cycles 07 INSTRUCTION: CP n ; opcode FE cycles 07
INSTRUCTION: RST 38H ; opcode FF cycles 11 INSTRUCTION: RST 38H ; opcode FF cycles 11
! : each-8bit ( n quot -- )
! 8 [ ! n quot bit
! pick over -1 * shift 1 bitand pick call
! ] repeat 2drop ;
!
! : >ppm ( cpu filename -- cpu )
! #! Dump the current screen image to a ppm image file with the given name.
! <file-writer> [
! "P3" print
! "256 224" print
! "1" print
! 224 [
! 32 [
! over 32 * over + HEX: 2400 + ! cpu h w addr
! >r pick r> swap cpu-ram nth [
! 0 = [
! " 0 0 0" write
! ] [
! " 1 1 1" write
! ] if
! ] each-8bit
! ] repeat nl
! ] repeat
! ] with-stream ;
: time-test ( -- )
test-cpu [ 1000000 run-n ] time ;

71
extra/cpu/8080/emulator/emulator.factor
View File

@ -1,10 +1,9 @@
! Copyright (C) 2006 Chris Double. ! Copyright (C) 2006 Chris Double.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
! !
USING: kernel math sequences words arrays io USING: kernel math sequences words arrays io io.files namespaces
io.files namespaces math.parser kernel.private math.parser assocs quotations parser parser-combinators
assocs quotations parser parser-combinators tools.time tools.time ;
sequences.private compiler.units ;
IN: cpu.8080.emulator IN: cpu.8080.emulator
TUPLE: cpu b c d e f h l a pc sp halted? last-interrupt cycles ram ; TUPLE: cpu b c d e f h l a pc sp halted? last-interrupt cycles ram ;
@ -396,39 +395,18 @@ M: cpu write-port ( value port cpu -- )
: instruction-cycles ( -- vector ) : instruction-cycles ( -- vector )
#! Return a 256 element vector containing the cycles for #! Return a 256 element vector containing the cycles for
#! each opcode in the 8080 instruction set. #! each opcode in the 8080 instruction set.
{ << 256 f <array> parsed >> ;
f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f
f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f
f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f
f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f
f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f
f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f
f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f
f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f } ;
: instructions ( -- vector )
#! Return a 256 element vector containing the emulation words for
#! each opcode in the 8080 instruction set.
{
f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f
f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f
f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f
f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f
f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f
f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f
f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f
f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f } ;
: not-implemented ( <cpu> -- ) : not-implemented ( <cpu> -- )
drop ; drop ;
instructions length [ : instructions ( -- vector )
dup instructions nth [ #! Return a 256 element vector containing the emulation words for
drop #! each opcode in the 8080 instruction set.
] [ << 256 [ [ not-implemented ] 2array ] map parsed >> ; inline
[ not-implemented ] swap instructions set-nth
] if : set-instruction ( quot n -- )
] each tuck >r 2array r> instructions set-nth ;
M: cpu reset ( cpu -- ) M: cpu reset ( cpu -- )
#! Reset the CPU to its poweron state #! Reset the CPU to its poweron state
@ -517,15 +495,6 @@ SYMBOL: rom-root
] if ] if
] if ; ] if ;
: step ( cpu -- )
#! Run a single 8080 instruction
[ read-instruction ] keep ! n cpu
over get-cycles over inc-cycles
[ swap instructions dispatch ] keep
[ cpu-pc HEX: FFFF bitand ] keep
[ set-cpu-pc ] keep
process-interrupts ;
: peek-instruction ( cpu -- word ) : peek-instruction ( cpu -- word )
#! Return the next instruction from the cpu's program #! Return the next instruction from the cpu's program
#! counter, but don't increment the counter. #! counter, but don't increment the counter.
@ -560,18 +529,6 @@ SYMBOL: rom-root
[ " cycles: " write cpu-cycles number>string 5 CHAR: \s pad-left write ] keep [ " cycles: " write cpu-cycles number>string 5 CHAR: \s pad-left write ] keep
nl drop ; nl drop ;
: test-step ( cpu -- cpu )
[ step ] keep dup cpu. ;
: test-cpu ( -- cpu )
<cpu> "invaders.rom" over load-rom dup cpu. ;
: test-n ( n -- )
test-cpu swap [ test-step ] times ;
: run-n ( cpu n -- cpu )
[ dup step ] times ;
: register-lookup ( string -- vector ) : register-lookup ( string -- vector )
#! Given a string containing a register name, return a vector #! Given a string containing a register name, return a vector
#! where the 1st item is the getter and the 2nd is the setter #! where the 1st item is the getter and the 2nd is the setter
@ -1337,11 +1294,9 @@ SYMBOL: last-opcode
#! Process the list of strings, which should make #! Process the list of strings, which should make
#! up an 8080 instruction, and output a quotation #! up an 8080 instruction, and output a quotation
#! that would implement that instruction. #! that would implement that instruction.
[
dup " " join instruction-quotations dup " " join instruction-quotations
>r "_" join [ "emulate-" % % ] "" make create-in dup last-instruction global set-at >r "_" join [ "emulate-" % % ] "" make create-in dup last-instruction global set-at
r> define r> define ;
] with-compilation-unit ;
: INSTRUCTION: ";" parse-tokens parse-instructions ; parsing : INSTRUCTION: ";" parse-tokens parse-instructions ; parsing
@ -1352,5 +1307,5 @@ SYMBOL: last-opcode
: opcode ( -- ) : opcode ( -- )
#! Set the opcode number for the last instruction that was defined. #! Set the opcode number for the last instruction that was defined.
last-instruction global at 1quotation scan 16 base> last-instruction global at 1quotation scan 16 base>
dup last-opcode global set-at instructions set-nth ; parsing dup last-opcode global set-at set-instruction ; parsing

51
extra/cpu/8080/test/test.factor Executable file
View File

@ -0,0 +1,51 @@
USING: kernel cpu.8080 cpu.8080.emulator math math io
tools.time combinators sequences io.files ;
IN: cpu.8080.test
: step ( cpu -- )
#! Run a single 8080 instruction
[ read-instruction ] keep ! n cpu
over get-cycles over inc-cycles
[ swap instructions case ] keep
[ cpu-pc HEX: FFFF bitand ] keep
[ set-cpu-pc ] keep
process-interrupts ;
: test-step ( cpu -- cpu )
[ step ] keep dup cpu. ;
: test-cpu ( -- cpu )
<cpu> "invaders.rom" over load-rom dup cpu. ;
: test-n ( n -- )
test-cpu swap [ test-step ] times drop ;
: run-n ( cpu n -- cpu )
[ dup step ] times ;
: each-8bit ( n quot -- )
8 -rot [ >r bit? r> call ] 2curry each ; inline
: >ppm ( cpu filename -- cpu )
#! Dump the current screen image to a ppm image file with the given name.
<file-writer> [
"P3" print
"256 224" print
"1" print
224 [
32 [
over 32 * over + HEX: 2400 + ! cpu h w addr
>r pick r> swap cpu-ram nth [
0 = [
" 0 0 0" write
] [
" 1 1 1" write
] if
] each-8bit drop
] each drop nl
] each
] with-stream ;
: time-test ( -- )
test-cpu [ 1000000 run-n drop ] time ;

15
extra/space-invaders/space-invaders.factor
View File

@ -1,11 +1,10 @@
! Copyright (C) 2006 Chris Double. ! Copyright (C) 2006 Chris Double.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
! !
USING: cpu.8080 cpu.8080.emulator openal math alien.c-types sequences kernel USING: cpu.8080 cpu.8080.emulator openal math alien.c-types
shuffle arrays io.files combinators kernel.private sequences kernel shuffle arrays io.files combinators ui.gestures
ui.gestures ui.gadgets ui.render opengl.gl system ui.gadgets ui.render opengl.gl system threads concurrency match
threads concurrency match ui byte-arrays combinators.lib ui byte-arrays combinators.lib ;
sequences.private ;
IN: space-invaders IN: space-invaders
TUPLE: space-invaders port1 port2i port2o port3o port4lo port4hi port5o bitmap sounds looping? ; TUPLE: space-invaders port1 port2i port2o port3o port4lo port4hi port5o bitmap sounds looping? ;
@ -191,7 +190,7 @@ M: space-invaders reset ( cpu -- )
: gui-step ( cpu -- ) : gui-step ( cpu -- )
[ read-instruction ] keep ! n cpu [ read-instruction ] keep ! n cpu
over get-cycles over inc-cycles over get-cycles over inc-cycles
[ swap instructions dispatch ] keep [ swap instructions case ] keep
[ cpu-pc HEX: FFFF bitand ] keep [ cpu-pc HEX: FFFF bitand ] keep
set-cpu-pc ; set-cpu-pc ;
@ -345,11 +344,13 @@ M: space-invaders update-video ( value addr cpu -- )
#! concurrent process. Messages can be sent to #! concurrent process. Messages can be sent to
#! signal key presses, etc. #! signal key presses, etc.
dup invaders-gadget-quit? [ dup invaders-gadget-quit? [
2drop
] [
[ sync-frame ] dip [ sync-frame ] dip
[ invaders-gadget-cpu gui-frame ] keep [ invaders-gadget-cpu gui-frame ] keep
[ relayout-1 ] keep [ relayout-1 ] keep
invaders-process invaders-process
] unless ; ] if ;
M: invaders-gadget graft* ( gadget -- ) M: invaders-gadget graft* ( gadget -- )
dup invaders-gadget-cpu init-sounds dup invaders-gadget-cpu init-sounds