fignition‎ > ‎Examples‎ > ‎

Examples 2


Contents

 Page 1
 Page 2
  1. Lunar Lander
  2. UDG Graphics Demo
  3. Timeout and EEPROM access
  4. Circles
  5. Noughts And Crosses (aka Tic-Tac-Toe).
  6. Line Drawing
  7. Conways Life
  8. Simple UDG Game Engine
  9. Forth Debugger.
  10. Mini Car Race
  11. Two Player Chess
  12. Brikky (A Breakout clone), With Audio.
  13. Maze Generator.
  1. Primes
  2. Calendar
  3. Pong
  4. i2c
  5. FIGgyBird
  6. Scientific Functions

Primes

This is a simple 1-block program to list all the prime numbers, it's really a kind of benchtest. You run it by typing, e.g. 1000 primes to list all the primes up to 1000.

: eloop 10 i@ 1- 12 i! ;

: primes
  2 swap 2 . 3 . 5
  do
    dup dup * i < if
      1+ then
    1 over 1+ 3 do
      r i mod 0= if
        1- eloop then
    2 +loop
    if
      i . then
  2 +loop
  drop ;

It was originally written for Mark Willis's TI 99/4a Turbo Forth and converted by David Bambrough and Carl Attril.

Calendar

David Bambrough converted Ricardo Lopez's Calendar program for the Jupiter Ace to FIGnition:

: weekday
 swap dup 3 < if          
  12 + rot
  1- rot rot
 then            
 26 * 54 - 10 / +
 swap 1900 -     
 dup 4 / + + 34 -
 7 mod           
;

: leapyear?
 dup 100 mod 0= 0=
 over 400 mod 0= or
 swap 4 mod 0= and
;

 : cal
 cr
 ." SU MO TU WE TH FR SA"
 cr
 over 3 * spaces decimal 
 1+ 1 do                
  i 10 < if
    1 spaces
  then
  i .             
  1+              
  dup 6 > if
   cr drop 0      
  then
 loop
 drop
;
 : month
 <builds 
   c, c,
 does> 
   over leapyear? 
   over 1+ c@     
   swap over
   2 = and -1 *
   rot c@ +       
   rot rot 1      
   weekday       
   swap          
   cal
;

 1  31 month january
2  28 month february
3  31 month march
4  30 month april
5  31 month may
6  30 month june
7  31 month july
8  31 month august
9  30 month september
10 31 month october
11 30 month november
12 31 month december


To use it, type (for example), 2013 april <exe> . The following screenshot shows the result from typing 2012 february <exe> 2012 may <exe>



Pong

A version of pong was originally developed for the Magnavox Odyssey home console by Ralph Baer, but first achieved mainstream acceptance with Atari's (improved) version of Pong in 1972. In that sense it's the video game that launched the industry. I've wanted to write a FIGnition version for quite a while, just to see how simple it can be. FIGnition's version requires firmware 0.9.8 or later, supports ball angles, and smooth bat movement, but currently lacks ball acceleration.

( Pong)
0 var lsc 0 var rsc ( scores)
0 var ly 0 var ry  ( l/r coord)
0 var bh ( ball height)
0 var by  0 var bx ( ball x,y)
0 var dx 0 var dy ( ball dir)
sysvars 11 + const joy
0 var audStop

: aud 64 191 42 >port>
  drop ;

: beep ( presc freq --)
 0 69 ic! ( sound off)
 0 110 ic! ( no ints)
 66 68 ic!  ( ctc mode)
 71 ic! ( pitch)
 7 and 69 ic! ( oct+on)
;

: audEnd
  audStop @ clock i@ -
  0< if
    0 0 beep
  then
;

: sfx
  8 clock i@ +
  audStop ! beep
;

clock i@ var seed
: rnd ( range -- rnd)
  seed @ 75 * 1+ dup
  seed ! u* swap drop
;


 : initBall
  3 198 sfx
  24 by ! 25 bx !
  2 rnd 2* 1- dy !
  2 rnd 2* 1- dx !
;

: mvBally    ( y )
  dy @ +
  dup 2 < over 47 > or if
    4 99 sfx
    dy @ neg dup dy ! +
  then
;

: .batUp ( y' dy x --)
  1 pen >r + r over plot
  2 pen bh @ + r>
  swap plot
;

: .batDn ( y' dy x --)
  1 pen >r drop
  r over bh @ + plot
  2 pen r> swap plot
; ( -- )


: mvBat ( j msk &y x )
  >r >r and dup 16 <
  over 0= 0= and swap
  15 > neg +
  r @ swap over + 2 max
  48 bh @ - min dup r> !
  over - r>
  over 0< if
    .batUp ;s
  then
  over neg 0< if
      .batDn
  else
    drop drop drop
  then
;
 : .sc
  6 0 at lsc @ 2 .r
  18 0 at rsc @ 2 .r
;

: init ( bh --)
  0 lsc ! 0 rsc !
  cls 1 pen .sc
  dup bh ! dup
  1 >> 24 swap
  - dup ly ! dup ry !
  swap over + swap do
    0 i plot 49 i plot
  loop
  48 0 do
    i 1 and 1+ pen
    25 i plot
  loop
  aud initBall
;

: bHit? ( x y limX &baty)
  @ >r over dup r 1- >
  swap r bh @ + < and
  >r rot = r> and if
    5 78 sfx
    dx @ neg dx !
    dup r bh @ 1 >> +
    - dy !
  then
  drop r> drop
; ( --)

: mvBallx ( x y)
  swap dx @ + swap
  2dup 1 ly bHit?
  2dup 48 ry bHit?
;

 : mvBall ( -- x)
  3 pen
  bx @ by @ 2dup >r >r
  mvBally mvBallx
  2dup plot by ! dup
  bx ! r> r> plot 1 pen
;
.
: score? ( x --)
  dup 0 < neg rsc +!
  dup 49 > neg lsc +!
  dup 0< over 49 > or if
    3 pen dup by @ plot
    .sc 50 pause
    initBall 1 pen
  then
  drop
;

: bats
  joy ic@
  dup $21 ly 0 mvBat
  $48 ry 49 mvBat
;

: pong ( speed bh --)
  init 1- ( speed)
  begin
    dup 0 do
      bats 0 pause
    loop
    bats mvBall score?
    0 pause audEnd
   lsc @ 15 = rsc @ 15 =
   or inkey asc A = or
  until
  0 0 beep drop
;


Here's a screenshot of FIGnition Pong in action:


The game itself is 162 lines long and occupies 2.9Kb of source or 862 bytes when compiled. It supports audio; different speeds and bat sizes (but no attract mode).

How to play (PONG needs Firmware 0.9.8):
  1. Load the game by loading the last block (it will load the rest).
  2. Type: speed batSize pong <exe> Usually I type 3 8 pong . The speed is the ratio of bat frames to ball frames, in this case 3 to 1.
  3. The left player uses SW1 and SW6 to go up and down; the right player uses SW4 and SW7 to go up and down.
  4. First person to 15 wins!

FIGnition Pong


I2C Access

It's possible to connect I2C devices to FIGnition entirely using Forth. I2C devices require the addition of a 1K8 (minimum) resistor between U1 Pin 8 and 5V and another similar resistor between U1 Pin 28 and 5V.


Oleg Kobchenko developed an I2C library for this purpose (slightly modified here):

( i2c/2-wire 0 [c]fig8r)
$B8 const twbr
$B9 const twsr
$BC const twcr
$BB const twdr
$BA const twar
$BD const twamr

create badI2c " bad i2c"

: ?twsr ( msk)
  twsr ic@ and 0=
  badI2c ?error
;
 : twcr! ( c-)
  $84 or twcr ic!
;

: ?twINT
  begin
    twcr ic@ $80 and
  until
;

: ?twSTO
  begin
    twcr ic@ $10 and
  0= until
;

 : i2ini
  0 twsr ic!
  $C0 twbr ic!
;

: {i2c ( addr)
  $20 twcr! ?twINT
  $18 ?twsr
  ( a) twdr ic! 0 twcr!
  ?twINT $58 ?twsr
;

: i2c}
  $10 twcr! ?twSTO
;

 : >i2c ( c)
  twdr ic! 0 twcr!
  ?twINT $28 ?twsr
;

: i2c> ( -c)
  $30 twcr! ?twINT
  twdr ic@
;

: i2c>- ( -c)
  0 twcr! ?twINT
  twdr ic@
;

For example, a Maxim 517 DAC I2C device can be used with a FIGnition with the following code:

( Maxim DAC bit 0=reg)
$4C const max517/8Base
$40 const max519Base

: >dac ( val addr)
  dup $FE and i2c{
    1 and >i2c >i2c
  }i2c
;
 ( demo code saw tooth)
max517/8Base const aDac

: demoDac
  begin
    256 0 do
      i aDac >dac
    loop
  inkey until
;


FIGgyBird

Here's a FIGnition version of the popular game in only 200 lines of code and 1026 bytes (when compiled).

create birdUp
$0102 , $040E , $1111 ,
$0906 , $F028 , $4C24 ,
$1E21 , $4F22 , $0201 ,
$0000 , $0000 , $0000 ,
$1CE0 , $0000 , $0000 ,
$0000 ,

create birdDn
$0102 , $0408 , $080E ,
$1111 , $F028 , $4C24 ,
$1E21 , $4F22 , $120D ,
$0000 , $0000 , $0000 ,
$1CE0 , $0000 , $0000 ,
$0000 ,

create pipe
$4A55 , $4A55 , $4A55 ,
$4A55 , $AEA6 , $AEA6 ,
$AEA6 , $AEA6 ,

create pipeEnd
$8095 , $AA95 , $AA95 ,
$AAFF , $0157 , $AB57 ,
$AB57 , $ABFF ,

0 var sc
0 var hi
16 const x
0 var y
-16 var oy
0 var vel
18 const g
0 var gameover
64 const thrust
40 const gap

3 const pipes
-1 var drift
3 arr pipeX
3 bytes pipeH

clock i@ var seed
: rnd ( range -- rnd )
  seed @ 1+ 75 * dup
  seed ! u* swap drop
;



: .stem ( x y h --)
  >r over 0 max over at
  over neg 160 + 17 min
  r clip
  r> 0 do ( x y)
    2dup i + over 1+
    over at at
    8 $0810 8 $0810 2blt
  8 +loop
  drop drop
  0 8 at 160 144 clip
;

: .pipe ( x h --)
  2dup 8 swap .stem
  2dup 8 + over 1+ over
  at at
  10 $810 10 $810 2blt
  2dup gap + over 1+
  over at at
  10 $810 10 $810 2blt
  104 over - swap [ gap
  8 + ] literal + swap
  .stem
;

: .status
  0 0 at 160 8 clip
  32 0 at sc @ .
 
;

: init
  0 sc ! 0 vel !
  $5000 y ! $F800 oy !
  0 0 at
  ." Sc: 0     Hi:"
  hi @ .
  birdUp $1010 0 tile
  birdDn $1010 4 tile
  pipe $0810 8 tile
  pipeEnd $0810 10 tile
  pipes 0 do
    i 80 * 160 + i pipeX !
    112 rnd i pipeH c!
  loop
;

: incSc ( pipeY)
  dup -5 = neg ?dup if
    sc +! .status
  then
;

: mvPipes
  pipes 0 do
    i pipeX dup @
    dup 160 < if
      dup i pipeH c@
      .pipe
    then
    1- incSc
    dup -16 < if
      drop 224
      112 rnd i pipeH c!
    then
    swap !
  loop
;

0 var flap

: wings ( thrust?)
  flap dup @ dup if
    1-
  else
    drop over 13 and
  then
  swap !
;

: .Bird
  8 oy c@ at
  8 y c@ at
  flap @ >r
  r 13 < r 5 > and
  4 and $1010
  r> 6 > 4 and $1010
  2blt
;

sysvars 11 + const joy

: doKey ( joy --)
  >r vel g
  r> thrust and
  0= 0= wings xor
  over @ + swap
  over swap !
  y >r r @ dup oy !
  + dup $700 -
  dup $8700 u< 0= if
    swap drop 0 vel !
    $BF80 u< $86FF and
    $701 + 0
  then
  drop r> !
;


: hit?
  0
  3 0 do
    i pipeX @ dup 23 <
    swap -5 > and if
      i pipeH c@ 15 +
      y c@ 2dup > >r
      gap - 25 + < r> or
      or
    then
  loop
;

: frame
  0 8 at 160 144 clip
  mvPipes .Bird
  joy ic@ doKey hit?
;

: hisc?
  sc @ hi @ max hi !
;
.
: bird
  1 vmode
  0 hi !
  begin
    cls init
    begin
      frame 0 pause
    until
    hisc?
  inkey drop
  key asc q = until
  0 vmode
;


Here's a screenshot of FIGgyBirds in action:


Scientific Functions


FIGnition supports Floating-Point arithmetic from firmware 1.0.0 onwards. Here's a useful set of trigonometric and logarithmic scientific functions to support them:

So what's in the package?

 Stack Inputs  Command  Effect  Action
 fx  fabs  |fx|  Calculates the absolute value of fx
 fx sqrt  √fx  Calculates the square root of fx 
   pi  π  Returns an approximation of π to 6.9 significant figures ( 3.141593..)
   e  e  Returns an approximation to the base for natural logarithms accurate to 6.9 significant figures (2.718282...)
 deg >rad  rad(deg)  Returns deg degrees converted to radians (2π radians = 360º). 
 rad sin   sin(rad)  Returns the sine of the radian angle rad.
 rad  cos cos(rad)   Returns the cosine of the radian angle rad.
 rad tan  tan(rad)  Returns the tangent of the radian angle rad, tangents very close to ±π/2 (±90º) will return overflow.
 fx asn  rad  Converts a sine value back into a radian angle, in the range 0 to π
 fx acs  rad  Converts a cosine value back into a radian angle, in the range -π/2 to π/2. 
fx  atn rad  Converts a  tangent value back into a radian angle, in the range 0 to π.
 fx exp  e^fx  The Exponential function, computes e to the power fx.
 fx ln   ln(fx) The natural logarithm function, computes ln(fx), unless x<0, in which case it returns overflow. 
fx fy  **  fx^fy  Calculates fx raised to the power fy, unless fy<0 in which case it returns an error, or x=0 and y!=0, in which case it returns 0, or x=y=0, in which case it returns 1.0. 


The code is attached and should compile to 878b or so. I's designed for compactness rather than performance or accuracy. The commands are based on ZX Basic commands rather than modern 'C' function terminology. There's no reason why you can't rename them.

( Transcendental Functions)

: fabs $7FFF and ;

: sqrt ( x -- sqrt[x])
 dup 0< if 
( if <0)
   2drop 1d ;s ( 
overflow)
 then
 dup 1 >> $7F80 and
 $1F80 - >r ( x : E/2)  
 $FF and $3F00 + 2dup fneg
 2swap ( -m m : E'/2)
 0d ( -m m dx : E'/2)
 begin
  f- ( -m m'-dx=>m' : E'/2)
  2over 2over ( -m m' -m m'..)
  2dup f* f+ ( -m m' m'^2-m..)
  
( .. [m'^2-m]/[2m']=>dx..) 
  2over $80 + f/
 dup fabs $3400 < until
 2drop 2swap 2drop ( m : E'/2)
 r> +
;

: cheb ( Z chebData )
 >r $80 + ( 2*Z : chebData )
 0d 0d 0d ( 2*Z, 0.0 0.0 0.0 )
 r> ( 2Z M2 T M1 cTable^ )
 dup 1+ swap c@ 0 do
  
( 2Z T -M2 /M1/ : cTable^)
  >r 2drop 2swap fneg
  ( 2Z T 2Z*T : -M2 cTable^)
  d>r 2over 2over f*
  ( 2Z T 2Z*T -M2 A : cT'^) 
  dr> r d@ r> 4 + >r
  
( 2Z T 2Z*T-M2+A : -M2 cT'^)
  2over d>r f+ f+ dr> r>
 loop
 drop f+ d>r 2drop
 2drop dr> ( T )
;
create pi -1 allot
 71 c, $40C90FDBd d,
create e -1 allot
 71 c, $40ADF854d d,

: >rad ( deg -- rad)
 [ pi 180. f/ ] dliteral f*
;

create kSinTab 6 c,  
 $B1E60000d d, $359F0B00d d,
 $B90F38EEd d, $3C1563BBd d,
 $BE920DCEd d, $40235D1Cd d,

: sin ( a -- sin[a])
 [ 0.5 pi f/ ] dliteral f*
 2dup 0.5 f+ fint float f-
 $0100 + ( in range -2 to 2)
 2dup fabs $-40000001d d+
 d0< 0= if ( abs[w]>1?)
  dup >r fabs fneg
  2.0 f+ ( -abs[w]+2)
  r> 0< if
   fneg ( -[-abs[w]+2])
  then
 then
 2dup 2dup f* $80 + 1.0 f-
 kSinTab cheb f*
;

: cos ( a -- cos[a] )
 [ pi 2.0 f/ ] dliteral f+
 sin
;

: tan ( a -- tan[a] )
 2dup sin 2swap cos f/
;

create kAtnTab 12 c,
 $AFB20000d d, $310E0000d d,
 $B2648D00d d, $33B9BC00d d,
 $B518FD00d d, $36803675d d,
 $B7DBE8B4d d, $3942C400d d,
 $BAB50937d d, $3C36731Bd d,
 $BDD8DE64d d, $3FE1A1B3d d,
: atn ( tan[a] -- a)
 dup fabs $4000
 < if ( abs[w]<1? y=x )
  0.0 ( y 0)
 else
  -1.0 2swap f/ dup >r
  [ pi -2.0 f/ ] dliteral
  r> $8000 and xor
 then
 2swap ( w y)
 2dup 2dup f* $80 + -1.0 f+
 kAtnTab cheb f* f+
;

: asn ( sin[a] -- a )
 2dup 2dup f* ( x x*x)
 fneg 1.0 f+ ( x 1-x*x)
 sqrt 1.0 f+ f/
 atn 2dup f+
;

: acs ( cos[a] -- a )
 asn fneg
 [ pi $80 - ] dliteral f+
;

create kExpTab 8 c,
 $31360000d d, $33E56600d d,
 $36786540d d, $38E032C9d d,
 $3B21F7AFd d, $3D2FB0B0d d,
 $3EFEBB94d d, $403A7EF9d d,

: exp ( fx--e^fx)
 2dup 88.7228391 f< 0= if
  2drop 1d ;s
 then
 1.44269504 f* 2dup fint ( y n)
 over >r float f- $80 + -1.0 f+
 kExpTab cheb r> 7 << +
;

create kLnTab 12 c,
 $B02C0000d d, $31890000d d,
 $B2DAA500d d, $3430C500d d,
 $B590AA00d d, $36F06F61d d,
 $B84BDA96d d, $39B19FB4d d,
 $BB20FE5Dd d, $3C9B43CAd d,
 $BE279C7Ed d, $3FEE2381d d,

: ln ( fx -- ln[fx])
 dup 0< if
  2drop 1d ;s
 then
 -3. 2swap dup ( -3. x x )
 7 >> $7F - >r ( -3. x : E')
 $7F and $3F80 + ( -3. x' : e' )  
 2dup $3FCCCCCDd f< if
   
( -3. [x'|2x'] : e'-1)
  r> 1- >r $80 +
 then
 
( -3.+[2.5|5]x' : )
 (    [x'|2x'] e'-1) )
 2dup d>r 2.5 f* f+
 kLnTab cheb dr> -1.0 f+
 f* ( Z'*[[x'|2x']-1] : e'-1)
 r> s->d float
 $3FB17218d f* f+
;

: ** ( fx fy)
 2swap 2dup or if
  ln f* exp
 else ( x=0)
  2drop 2dup or if
   2drop 1.0 ( 0**0=1)
  else ( -ve => overflow else 0)
   swap drop 15 >> 0
  then
 then
;


Most of FIGnition's tiny scientific package uses Chebyshev polynomials to approximate calculations to an accuracy adequate for single-precision floating-point arithmetic. The exception is sqrt, which uses a Newton-Raphson approximation.


ċ
Julian Skidmore,
23 Mar 2014, 02:16
ċ
MathTrans.fth
(3k)
Julian Skidmore,
16 Jul 2014, 10:36
ċ
Julian Skidmore,
25 Nov 2013, 03:22
Comments