Groups | Search | Server Info | Keyboard shortcuts | Login | Register [http] [https] [nntp] [nntps]
Groups > comp.lang.forth > #35175 > unrolled thread
| Started by | humptydumpty <ouatubi@gmail.com> |
|---|---|
| First post | 2014-12-23 23:44 -0800 |
| Last post | 2015-01-07 10:44 -0800 |
| Articles | 10 — 8 participants |
Back to article view | Back to comp.lang.forth
Christmas Card humptydumpty <ouatubi@gmail.com> - 2014-12-23 23:44 -0800
Re: Christmas Card "David N. Williams" <williams@umich.edu> - 2014-12-24 08:09 -0500
Re: Christmas Card Paul E Bennett <Paul_E.Bennett@topmail.co.uk> - 2014-12-24 15:31 +0000
Re: Christmas Card Coos Haak <chforth@hccnet.nl> - 2014-12-24 17:42 +0100
Re: Christmas Card mhx@iae.nl - 2014-12-24 12:04 -0800
Re: Christmas Card visualforth@rocketmail.com - 2014-12-24 12:42 -0800
Re: Christmas Card Matthias Koch <matthias.koch@hot.uni-hannover.de> - 2015-01-07 11:42 +0100
Re: Christmas Card humptydumpty <ouatubi@gmail.com> - 2015-01-07 05:19 -0800
Re: Christmas Card Matthias Koch <matthias.koch@hot.uni-hannover.de> - 2015-01-07 18:34 +0100
Re: Christmas Card Steve Graham <jsgrahamus@yahoo.com> - 2015-01-07 10:44 -0800
| From | humptydumpty <ouatubi@gmail.com> |
|---|---|
| Date | 2014-12-23 23:44 -0800 |
| Subject | Christmas Card |
| Message-ID | <84b9a45f-2172-44d2-a271-26543183acad@googlegroups.com> |
Hi all!
From collision of thiking to make a Christmas card and some fooling around
with permutations, resulted something not permutations nor an usual card,
tested under GForth:
--->8
\ Christmas Card
\ Author: Ouatu Bogdan Ionut ouatubi@gmail.com (humptydumpty)
\ Date: 19 Dec 2014
\ Contains a 'Qualitative snow fall simulator' developed by author.
\ Merry Christmas everyone!
' noop is bootmessage
: 4dup 2over 2over ;
VARIABLE COLS# VARIABLE ROWS#
: s!
dup allot rot swap MOVE
;
CREATE CARD
HERE s" " dup COLS# ! s!
HERE s" + " s!
HERE s" A " s!
HERE s" / \ " s!
HERE s" / Q \ " s!
HERE s" /^ ^ ^\ " s!
HERE s" / &\ " s!
HERE s" /J ^ \ " s!
HERE s" / ( ) i\ " s!
HERE s" / ^ - ^ \ " s!
HERE s" ^^( ) \. ^^ " s!
HERE s" - \( ) " s!
HERE s" / ^ \- " s!
HERE s" . i J \ " s!
HERE s" / & ^ ^ &^ " s!
HERE s" ^ J ( ) \ " s!
HERE s" / ^ ^ - ^ \ " s!
HERE s" / ( ) & J & ^ " s!
HERE s" ^ J - ^ ^ \ " s!
HERE s" / C i ( ) \ " s!
HERE s" ^^ ^ ^ ^ ^__^ ^ - ^ ^^^ " s!
HERE s" | | " s!
HERE s" MERRY CHRISTMAS! " s!
HERE CONSTANT ENDCARD
ENDCARD CARD - COLS# @ / ROWS# !
: xy@ ( cx cy -- c ;return CHAR at X Y from card )
COLS# @ * + CARD + c@
;
: show
ENDCARD CARD
DO
I COLS# @ type CR
COLS# @ +LOOP
;
: field+! ( cfield object -- object' )
8 lshift or
;
: field@+ ( object -- field object' )
dup 255 and swap 8 rshift
;
: new ( cx cy cindex c -- object )
0 field+! field+! field+! field+!
;
: object ( object -- cx cy cindex c )
field@+ field@+ field@+ field@+ drop
;
CREATE ooers 23 8 0 BL new , 20 10 1 BL new , 28 11 2 BL new , 25 15 2 BL new , 18 17 0 BL new , 28 19 1 BL new ,
HERE CONSTANT endooers
:noname at-xy [char] O emit ;
:noname at-xy [char] o emit ;
:noname at-xy [char] . emit ;
, , , HERE 3 cells - CONSTANT dooers
: index++ ( cindex -- cindex' )
1+ 3 mod
;
: doo ( -- ; execute each ooer object and its index++ )
endooers ooers
DO
I @ object 4dup
drop cells dooers + @ execute
swap index++ swap new I !
[ 1 cells ] LITERAL +LOOP
;
\ *******************************
\ QUALITATIVE SNOW FALL SIMULATOR
\ *******************************
\ Tor space
: x++ ( cx -- cx' )
1+ COLS# @ MOD
;
: x-- ( cx -- cx' )
1 - COLS# @ MOD
;
: y++ ( cy -- cy' )
1+ ROWS# @ MOD
;
: y-- ( cy -- cy' )
1 - ROWS# @ MOD
;
\ Snail of quantified snowflake Momentum
\ 432
\ 501
\ 678 0 means no momentum, 1 momentum to right side, ...
\ Here is Momentum Index -> Movements Table
:noname swap x++ swap y++ ; \ 8
:noname y++ ; \ 7
:noname swap x-- swap y++ ; \ 6
:noname swap x-- swap ; \ 5
:noname swap x-- swap y-- ; \ 4
:noname y-- ; \ 3
:noname swap x++ swap y-- ; \ 2
:noname swap x++ swap ; \ 1
:noname ; \ 0
, , , , , , , , , HERE 9 cells - CONSTANT MOVES
\ As we know, change of body Momentum is proportional to Force exerted to that body.
\ Here is encrypted changes of various Forces to snowflake Momentum
CREATE Gravitation 7 c, 8 c, 1 c, 0 c, 5 c, 6 c, 7 c, 7 c, 7 c,
CREATE WestWind 1 c, 1 c, 1 c, 2 c, 3 c, 0 c, 7 c, 8 c, 1 c,
CREATE EastWind 5 c, 0 c, 3 c, 4 c, 5 c, 5 c, 5 c, 6 c, 7 c,
CREATE Nothing 0 c, 1 c, 2 c, 3 c, 4 c, 5 c, 6 c, 7 c, 8 c,
CREATE Geom+ 0 c, 2 c, 3 c, 4 c, 5 c, 6 c, 7 c, 8 c, 1 c,
CREATE Geom- 0 c, 8 c, 1 c, 2 c, 3 c, 4 c, 5 c, 6 c, 7 c,
\ IMPORTANT: as ratio surface/volume >> 1 of a snowflake (small&fractal-like geometry)
\ surface derived forces prevails on inertial ones. Example: air resistance force
\ that counterbalance gravitational force will be achieved for relatively small fall speed.
\ As snowflake moves through the air, peculiar geometry of snowflake
\ induces deviation forces, Geom+-. It introduces randomness
\ to snowflake flight.
\ Winds behavior.
CREATE WINDS WestWind , Nothing , EastWind , Nothing ,
VARIABLE Windex Windex OFF
: windex++ Windex @ 1 + 4 MOD Windex ! ;
: Wind WINDS Windex @ cells + @ ;
include random.fs
\ Randomness behavior.
CREATE GEOMS Nothing , Geom+ , Nothing , Geom- , Nothing ,
: Geom 5 random cells GEOMS + @ ;
\ Snowflake object description: cx cy cmomentumindex cbackground
: fly ( cx cy cmindex -- cx' cy' cmindex' ; calculate new position and momentum )
Gravitation + c@ Wind + c@ Geom + c@
dup >R
cells MOVES + @ EXECUTE
R>
;
CREATE Flakes 50 0 0 BL new , 10 0 0 BL new , 15 0 0 BL new , 20 0 0 BL new , 25 0 0 BL new , 30 0 0 BL new , 35 0 0 BL n
ew , 40 0 0 BL new , 45 0 0 BL new ,
HERE CONSTANT EndFlakes
: dosnow ( -- ; snowflake dance )
EndFlakes Flakes
DO
I @ object 4dup
>R drop at-xy R> emit \ restore background to old position
drop fly >R \ new position&momentum
2dup at-xy [CHAR] * emit \ snow paint
2dup xy@ R> swap \ get background at new position
new I ! \ make&store the new object
[ 1 cells ] LITERAL +LOOP
;
: merry-Christmas ( -- )
page show 1
BEGIN
key? 0=
WHILE
dosnow
dup 4 mod 0= IF doo THEN
dup 30 mod 0= IF windex++ THEN
0 0 at-xy
1+
300 ms
REPEAT
drop
0 ROWS# @ at-xy BL EMIT
;
merry-Christmas bye
--->8
Usage: gforth merry-christmas.fs
I hope you enjoy the card and the little food for thought included in this forth source!
Merry Christmas!
sincerely yours humptydumpty
[toc] | [next] | [standalone]
| From | "David N. Williams" <williams@umich.edu> |
|---|---|
| Date | 2014-12-24 08:09 -0500 |
| Message-ID | <m7edso$u7p$1@dont-email.me> |
| In reply to | #35175 |
On 12/24/14 2:44 AM, humptydumpty wrote: > Hi all! > > From collision of thiking to make a Christmas card and some fooling around > with permutations, resulted something not permutations nor an usual card, > tested under GForth: > [...] Thanks! Very nice! -- David
[toc] | [prev] | [next] | [standalone]
| From | Paul E Bennett <Paul_E.Bennett@topmail.co.uk> |
|---|---|
| Date | 2014-12-24 15:31 +0000 |
| Message-ID | <cg04i0FufttU1@mid.individual.net> |
| In reply to | #35175 |
humptydumpty wrote: > Hi all! > > From collision of thiking to make a Christmas card and some fooling around > with permutations, resulted something not permutations nor an usual card, > tested under GForth: > > --->8 [%X] Initially had to resolve the page-width issue as some comment text and code got wrapped by my editor. Then had to figure out the differences between your Random and the one in VFX. I ended up redifining the VFX random with:- : RANDOM ( S: n -- #rand ) \ G: Return a random positive number modulo n RANDOM SWAP MOD ABS ; The end result is very pleasing. Well done HumptyDumpty. Happy Yuletide to all, and a Prosperous New Year Forthing away. -- ******************************************************************** Paul E. Bennett IEng MIET.....<email://Paul_E.Bennett@topmail.co.uk> Forth based HIDECS Consultancy.............<http://www.hidecs.co.uk> Mob: +44 (0)7811-639972 Tel: +44 (0)1235-510979 Going Forth Safely ..... EBA. www.electric-boat-association.org.uk.. ********************************************************************
[toc] | [prev] | [next] | [standalone]
| From | Coos Haak <chforth@hccnet.nl> |
|---|---|
| Date | 2014-12-24 17:42 +0100 |
| Message-ID | <1wu1fm0e4g987.67kct4uxu1wd.dlg@40tude.net> |
| In reply to | #35188 |
Op Wed, 24 Dec 2014 15:31:11 +0000 schreef Paul E Bennett: > humptydumpty wrote: > >> Hi all! >> >> From collision of thiking to make a Christmas card and some fooling around >> with permutations, resulted something not permutations nor an usual card, >> tested under GForth: >> >> --->8 > > [%X] > > Initially had to resolve the page-width issue as some comment text and code > got wrapped by my editor. Then had to figure out the differences between > your Random and the one in VFX. > > I ended up redifining the VFX random with:- > >: RANDOM ( S: n -- #rand ) > \ G: Return a random positive number modulo n > RANDOM SWAP > MOD ABS > ; : RANDOM ( S: u -- #rand ) \ G: Return a random unsigned number modulo u RANDOM UM* NIP ; Multiplying is a lot faster on most processors, and if you by accident use zero for n, no exception is issued. And the range is twofold. > > The end result is very pleasing. Well done HumptyDumpty. > > Happy Yuletide to all, and a Prosperous New Year Forthing away. Prettige kerstdagen en een gelukkig nieuwjaar. -- Coos CHForth, 16 bit DOS applications http://home.hccnet.nl/j.j.haak/forth.html
[toc] | [prev] | [next] | [standalone]
| From | mhx@iae.nl |
|---|---|
| Date | 2014-12-24 12:04 -0800 |
| Message-ID | <52d1cf3d-8e9f-4153-8c2a-5ce713744b37@googlegroups.com> |
| In reply to | #35175 |
On Wednesday, December 24, 2014 8:44:50 AM UTC+1, humptydumpty wrote:
> Hi all!
>
> From collision of thiking to make a Christmas card and some fooling around
> with permutations, resulted something not permutations nor an usual card,
> tested under GForth:
This caused a rather lengthy debugging session :-)
: x-- ( cx -- cx' )
1 - ( COLS# @ MOD ) S>D COLS# @ FM/MOD DROP
;
: y++ ( cy -- cy' )
1+ ROWS# @ MOD
;
: y-- ( cy -- cy' )
1 - ( ROWS# @ MOD ) S>D ROWS# @ FM/MOD DROP
;
With the standard division it doesn't take long before
a new object is formed that will cause MOVES to index
out of the xt-token table.
Here is a colored Christmas tree:
: coemit ( char -- ) TextFGColor >R 256 choose @color TO TextFGColor SetTerm EMIT R> TO TextFGColor SetTerm ;
:noname at-xy [char] O coemit ;
:noname at-xy [char] o coemit ;
:noname at-xy [char] . coemit ;
, , , HERE 3 cells - CONSTANT dooers
-marcel
[toc] | [prev] | [next] | [standalone]
| From | visualforth@rocketmail.com |
|---|---|
| Date | 2014-12-24 12:42 -0800 |
| Message-ID | <7b53871b-572e-4f2c-9505-6618ff40fb9a@googlegroups.com> |
| In reply to | #35175 |
On Wednesday, December 24, 2014 2:44:50 AM UTC-5, humptydumpty wrote: > Hi all! > > From collision of thiking to make a Christmas card and some fooling around > with permutations, resulted something not permutations nor an usual card, > tested under GForth: > > --->8 > > \ Christmas Card > \ Author: Ouatu Bogdan Ionut (humptydumpty) > \ Date: 19 Dec 2014 > \ Contains a 'Qualitative snow fall simulator' developed by author. > \ Merry Christmas everyone! > > ' noop is bootmessage > > : 4dup 2over 2over ; > > VARIABLE COLS# VARIABLE ROWS# > : s! > dup allot rot swap MOVE > ; > > CREATE CARD > HERE s" " dup COLS# ! s! > HERE s" + " s! > HERE s" A " s! > HERE s" / \ " s! > HERE s" / Q \ " s! > HERE s" /^ ^ ^\ " s! > HERE s" / &\ " s! > HERE s" /J ^ \ " s! > HERE s" / ( ) i\ " s! > HERE s" / ^ - ^ \ " s! > HERE s" ^^( ) \. ^^ " s! > HERE s" - \( ) " s! > HERE s" / ^ \- " s! > HERE s" . i J \ " s! > HERE s" / & ^ ^ &^ " s! > HERE s" ^ J ( ) \ " s! > HERE s" / ^ ^ - ^ \ " s! > HERE s" / ( ) & J & ^ " s! > HERE s" ^ J - ^ ^ \ " s! > HERE s" / C i ( ) \ " s! > HERE s" ^^ ^ ^ ^ ^__^ ^ - ^ ^^^ " s! > HERE s" | | " s! > HERE s" MERRY CHRISTMAS! " s! > HERE CONSTANT ENDCARD > ENDCARD CARD - COLS# @ / ROWS# ! > > : xy@ ( cx cy -- c ;return CHAR at X Y from card ) > COLS# @ * + CARD + c@ > ; > : show > ENDCARD CARD > DO > I COLS# @ type CR > COLS# @ +LOOP > ; > : field+! ( cfield object -- object' ) > 8 lshift or > ; > : field@+ ( object -- field object' ) > dup 255 and swap 8 rshift > ; > : new ( cx cy cindex c -- object ) > 0 field+! field+! field+! field+! > ; > : object ( object -- cx cy cindex c ) > field@+ field@+ field@+ field@+ drop > ; > > CREATE ooers 23 8 0 BL new , 20 10 1 BL new , 28 11 2 BL new , 25 15 2 BL new , 18 17 0 BL new , 28 19 1 BL new , > HERE CONSTANT endooers > > :noname at-xy [char] O emit ; > :noname at-xy [char] o emit ; > :noname at-xy [char] . emit ; > , , , HERE 3 cells - CONSTANT dooers > > : index++ ( cindex -- cindex' ) > 1+ 3 mod > ; > : doo ( -- ; execute each ooer object and its index++ ) > endooers ooers > DO > I @ object 4dup > drop cells dooers + @ execute > swap index++ swap new I ! > [ 1 cells ] LITERAL +LOOP > ; > > \ ******************************* > \ QUALITATIVE SNOW FALL SIMULATOR > \ ******************************* > \ Tor space > : x++ ( cx -- cx' ) > 1+ COLS# @ MOD > ; > : x-- ( cx -- cx' ) > 1 - COLS# @ MOD > ; > : y++ ( cy -- cy' ) > 1+ ROWS# @ MOD > ; > : y-- ( cy -- cy' ) > 1 - ROWS# @ MOD > ; > > \ Snail of quantified snowflake Momentum > \ 432 > \ 501 > \ 678 0 means no momentum, 1 momentum to right side, ... > \ Here is Momentum Index -> Movements Table > :noname swap x++ swap y++ ; \ 8 > :noname y++ ; \ 7 > :noname swap x-- swap y++ ; \ 6 > :noname swap x-- swap ; \ 5 > :noname swap x-- swap y-- ; \ 4 > :noname y-- ; \ 3 > :noname swap x++ swap y-- ; \ 2 > :noname swap x++ swap ; \ 1 > :noname ; \ 0 > , , , , , , , , , HERE 9 cells - CONSTANT MOVES > > \ As we know, change of body Momentum is proportional to Force exerted to that body. > \ Here is encrypted changes of various Forces to snowflake Momentum > CREATE Gravitation 7 c, 8 c, 1 c, 0 c, 5 c, 6 c, 7 c, 7 c, 7 c, > CREATE WestWind 1 c, 1 c, 1 c, 2 c, 3 c, 0 c, 7 c, 8 c, 1 c, > CREATE EastWind 5 c, 0 c, 3 c, 4 c, 5 c, 5 c, 5 c, 6 c, 7 c, > CREATE Nothing 0 c, 1 c, 2 c, 3 c, 4 c, 5 c, 6 c, 7 c, 8 c, > CREATE Geom+ 0 c, 2 c, 3 c, 4 c, 5 c, 6 c, 7 c, 8 c, 1 c, > CREATE Geom- 0 c, 8 c, 1 c, 2 c, 3 c, 4 c, 5 c, 6 c, 7 c, > \ IMPORTANT: as ratio surface/volume >> 1 of a snowflake (small&fractal-like geometry) > \ surface derived forces prevails on inertial ones. Example: air resistance force > \ that counterbalance gravitational force will be achieved for relatively small fall speed. > \ As snowflake moves through the air, peculiar geometry of snowflake > \ induces deviation forces, Geom+-. It introduces randomness > \ to snowflake flight. > > \ Winds behavior. > CREATE WINDS WestWind , Nothing , EastWind , Nothing , > VARIABLE Windex Windex OFF > : windex++ Windex @ 1 + 4 MOD Windex ! ; > : Wind WINDS Windex @ cells + @ ; > > include random.fs > > \ Randomness behavior. > CREATE GEOMS Nothing , Geom+ , Nothing , Geom- , Nothing , > : Geom 5 random cells GEOMS + @ ; > > \ Snowflake object description: cx cy cmomentumindex cbackground > > : fly ( cx cy cmindex -- cx' cy' cmindex' ; calculate new position and momentum ) > Gravitation + c@ Wind + c@ Geom + c@ > dup >R > cells MOVES + @ EXECUTE > R> > ; > > CREATE Flakes 50 0 0 BL new , 10 0 0 BL new , 15 0 0 BL new , 20 0 0 BL new , 25 0 0 BL new , 30 0 0 BL new , 35 0 0 BL n > ew , 40 0 0 BL new , 45 0 0 BL new , > HERE CONSTANT EndFlakes > > : dosnow ( -- ; snowflake dance ) > EndFlakes Flakes > DO > I @ object 4dup > >R drop at-xy R> emit \ restore background to old position > drop fly >R \ new position&momentum > 2dup at-xy [CHAR] * emit \ snow paint > 2dup xy@ R> swap \ get background at new position > new I ! \ make&store the new object > [ 1 cells ] LITERAL +LOOP > ; > > : merry-Christmas ( -- ) > page show 1 > BEGIN > key? 0= > WHILE > dosnow > dup 4 mod 0= IF doo THEN > dup 30 mod 0= IF windex++ THEN > 0 0 at-xy > 1+ > 300 ms > REPEAT > drop > 0 ROWS# @ at-xy BL EMIT > ; > merry-Christmas bye > > --->8 > > Usage: gforth merry-christmas.fs > > I hope you enjoy the card and the little food for thought included in this forth source! > > Merry Christmas! > sincerely yours humptydumpty humptydumpty, That's amazing! It worked immediately with Win32Forth after removing ' noop is bootmessage' and 'include random.fs' as well as breaking some lines at the 'CREATE ooers' and 'CREATE Flakes' definitions. Great! Have a blessed Christmas and a peaceful New Year!
[toc] | [prev] | [next] | [standalone]
| From | Matthias Koch <matthias.koch@hot.uni-hannover.de> |
|---|---|
| Date | 2015-01-07 11:42 +0100 |
| Message-ID | <m8j2ts$8jp$1@newsserver.rrzn.uni-hannover.de> |
| In reply to | #35175 |
Thank you for the very nice Christmas card !
May a change it a bit to run on Mecrisp-Stellaris and include your snowy Christmas tree as an example with credits into the mainstream release ? It is really a beautiful snow flake movement simulation. Are you from physics, too ?
Best wishes from Germany for the new year,
Matthias Koch
+
A
* / \ *
/ Q \
* * /^ ^ ^\
/ &\
*J ^ \
/ (.) i\
/ ^ - ^ \
^^(o) \. ^^
- \(O) *
/ ^ \- *
. i J \
/ & ^ ^ &^
^ J (O) \
/ ^ ^ - ^ \
/ (.) & J & ^
^ J - *^ ^ \
* / C i (o) \
^^ ^ ^ ^ ^__^ ^ - ^ ^^^
| |
MERRY CHRISTMAS!
[toc] | [prev] | [next] | [standalone]
| From | humptydumpty <ouatubi@gmail.com> |
|---|---|
| Date | 2015-01-07 05:19 -0800 |
| Message-ID | <301db5d8-3b39-4595-90d0-0d4fdc67f2a3@googlegroups.com> |
| In reply to | #35532 |
On Wednesday, January 7, 2015 12:48:29 PM UTC+2, Matthias Koch wrote: > Thank you for the very nice Christmas card ! > > May a change it a bit to run on Mecrisp-Stellaris and include your snowy Christmas tree as an example with credits into the mainstream release ? It is really a beautiful snow flake movement simulation. Are you from physics, too ? > > Best wishes from Germany for the new year, > Matthias Koch > > > + > A > * / \ * > / Q \ > * * /^ ^ ^\ > / &\ > *J ^ \ > / (.) i\ > / ^ - ^ \ > ^^(o) \. ^^ > - \(O) * > / ^ \- * > . i J \ > / & ^ ^ &^ > ^ J (O) \ > / ^ ^ - ^ \ > / (.) & J & ^ > ^ J - *^ ^ \ > * / C i (o) \ > ^^ ^ ^ ^ ^__^ ^ - ^ ^^^ > | | > MERRY CHRISTMAS! Hi! You are free to do everything you wish. Is a Christmas gift for everyone. :) My hobbies includes physics :) Have a nice day, humptydumpty
[toc] | [prev] | [next] | [standalone]
| From | Matthias Koch <matthias.koch@hot.uni-hannover.de> |
|---|---|
| Date | 2015-01-07 18:34 +0100 |
| Message-ID | <m8jr1u$6ef$1@newsserver.rrzn.uni-hannover.de> |
| In reply to | #35539 |
> Hi!
>
> You are free to do everything you wish. Is a Christmas gift for everyone. :)
> My hobbies includes physics :)
>
> Have a nice day,
> humptydumpty
Thank you ! Now I ported your artwork to the Stellaris Launchpad:
\ -----------------------------------------------------------------------------
\ Delay with Systick-Timer for 16 MHz
\ -----------------------------------------------------------------------------
$E000E010 constant NVIC_ST_CTRL_R
$E000E014 constant NVIC_ST_RELOAD_R
$E000E018 constant NVIC_ST_CURRENT_R
: init-delay ( -- ) \ Start free running Systick Timer
0 NVIC_ST_CTRL_R !
$00FFFFFF NVIC_ST_RELOAD_R !
0 NVIC_ST_CURRENT_R !
%101 NVIC_ST_CTRL_R !
;
: delay-ticks ( ticks -- ) \ Tick = 1/16MHz = 62.5 ns
NVIC_ST_CURRENT_R @ \ Get the starting time
swap - \ Subtract ticks to wait
dup 0< if \ If difference is negative...
$00FFFFFF and \ Convert to 24-bit subtraction to calculate value after rollover
begin $800000 NVIC_ST_CURRENT_R bit@ until \ Wait for next rollover
then
begin dup NVIC_ST_CURRENT_R @ u>= until
drop
;
\ Values for 16 MHz:
: us ( us -- ) 16 * delay-ticks ;
: ms ( ms -- ) 0 ?do 16000 delay-ticks loop ;
\ -----------------------------------------------------------------------------
\ Small random for targets without hardware random number generator )
\ -----------------------------------------------------------------------------
: smallrandom ( u -- u ) NVIC_ST_CURRENT_R @ swap u/mod drop ;
\ -----------------------------------------------------------------------------
\ Terminal handling routines
\ -----------------------------------------------------------------------------
: u.base10 ( u -- ) base @ decimal swap 0 <# #s #> type base ! ;
: ESC[ ( -- ) 27 emit 91 emit ;
: at-xy ( column row -- ) 1+ swap 1+ swap ESC[ u.base10 ." ;" u.base10 ." H" ;
: page ESC[ ." 2J" 0 0 at-xy ;
\ -----------------------------------------------------------------------------
\ -----------------------------------------------------------------------------
\ Christmas Card
\ Author: Ouatu Bogdan Ionut ouatubi@gmail.com (humptydumpty)
\ Date: 19 Dec 2014
\ Contains a 'Qualitative snow fall simulator' developed by author.
\ Merry Christmas everyone!
\ Changed for Mecrisp-Stellaris by Matthias Koch, January 2015
: 4dup 2over 2over ;
: s! ( addr length -- ) 0 do dup i + c@ c, loop drop ;
CREATE CARD
char " parse " dup -rot s!
char " parse + " s!
char " parse A " s!
char " parse / \ " s!
char " parse / Q \ " s!
char " parse /^ ^ ^\ " s!
char " parse / &\ " s!
char " parse /J ^ \ " s!
char " parse / ( ) i\ " s!
char " parse / ^ - ^ \ " s!
char " parse ^^( ) \. ^^ " s!
char " parse - \( ) " s!
char " parse / ^ \- " s!
char " parse . i J \ " s!
char " parse / & ^ ^ &^ " s!
char " parse ^ J ( ) \ " s!
char " parse / ^ ^ - ^ \ " s!
char " parse / ( ) & J & ^ " s!
char " parse ^ J - ^ ^ \ " s!
char " parse / C i ( ) \ " s!
char " parse ^^ ^ ^ ^ ^__^ ^ - ^ ^^^ " s!
char " parse | | " s!
char " parse MERRY CHRISTMAS! " s!
HERE align CONSTANT ENDCARD
CONSTANT COLS#
ENDCARD CARD - COLS# / CONSTANT ROWS#
: xy@ ( cx cy -- c ;return CHAR at X Y from card )
COLS# * + CARD + c@
;
: show
ENDCARD CARD
DO
I COLS# type CR
COLS# +LOOP
;
: field+! ( cfield object -- object' )
8 lshift or
;
: field@+ ( object -- field object' )
dup 255 and swap 8 rshift
;
: new ( cx cy cindex c -- object )
0 field+! field+! field+! field+!
;
: object ( object -- cx cy cindex c )
field@+ field@+ field@+ field@+ drop
;
23 8 0 BL new
20 10 1 BL new
28 11 2 BL new
25 15 2 BL new
18 17 0 BL new
28 19 1 BL new
6 nvariable ooers
ooers 6 cells + constant endooers
: o3 at-xy [char] O emit ; ' o3
: o2 at-xy [char] o emit ; ' o2
: o1 at-xy [char] . emit ; ' o1
, , , HERE 3 cells - CONSTANT dooers
: index++ ( cindex -- cindex' )
1+ 3 mod
;
: doo ( -- ; execute each ooer object and its index++ )
endooers ooers
DO
I @ object 4dup
drop cells dooers + @ execute
swap index++ swap new I !
1 CELLS +LOOP
;
\ *******************************
\ QUALITATIVE SNOW FALL SIMULATOR
\ *******************************
\ Tor space
: x++ ( cx -- cx' )
1+ dup COLS# >= if drop 0 then
;
: x-- ( cx -- cx' )
1- dup 0< if drop COLS# 1- then
;
: y++ ( cy -- cy' )
1+ dup ROWS# >= if drop 0 then
;
: y-- ( cy -- cy' )
1- dup 0< if drop ROWS# 1- then
;
\ Snail of quantified snowflake Momentum
\ 432
\ 501
\ 678 0 means no momentum, 1 momentum to right side, ...
\ Here is Momentum Index -> Movements Table
: m8 swap x++ swap y++ ; ' m8 \ 8
: m7 y++ ; ' m7 \ 7
: m6 swap x-- swap y++ ; ' m6 \ 6
: m5 swap x-- swap ; ' m5 \ 5
: m4 swap x-- swap y-- ; ' m4 \ 4
: m3 y-- ; ' m3 \ 3
: m2 swap x++ swap y-- ; ' m2 \ 2
: m1 swap x++ swap ; ' m1 \ 1
: m0 ; ' m0 \ 0
, , , , , , , , , HERE 9 cells - CONSTANT MOVES
\ As we know, change of body Momentum is proportional to Force exerted to that body.
\ Here is encrypted changes of various Forces to snowflake Momentum
CREATE Gravitation 7 c, 8 c, 1 c, 0 c, 5 c, 6 c, 7 c, 7 c, 7 c, align
CREATE WestWind 1 c, 1 c, 1 c, 2 c, 3 c, 0 c, 7 c, 8 c, 1 c, align
CREATE EastWind 5 c, 0 c, 3 c, 4 c, 5 c, 5 c, 5 c, 6 c, 7 c, align
CREATE Nothing 0 c, 1 c, 2 c, 3 c, 4 c, 5 c, 6 c, 7 c, 8 c, align
CREATE Geom+ 0 c, 2 c, 3 c, 4 c, 5 c, 6 c, 7 c, 8 c, 1 c, align
CREATE Geom- 0 c, 8 c, 1 c, 2 c, 3 c, 4 c, 5 c, 6 c, 7 c, align
\ IMPORTANT: as ratio surface/volume >> 1 of a snowflake (small&fractal-like geometry)
\ surface derived forces prevails on inertial ones. Example: air resistance force
\ that counterbalance gravitational force will be achieved for relatively small fall speed.
\ As snowflake moves through the air, peculiar geometry of snowflake
\ induces deviation forces, Geom+-. It introduces randomness
\ to snowflake flight.
\ Winds behavior.
CREATE WINDS WestWind , Nothing , EastWind , Nothing ,
0 VARIABLE Windex
: windex++ Windex @ 1 + 4 MOD Windex ! ;
: Wind WINDS Windex @ cells + @ ;
\ Randomness behavior.
CREATE GEOMS Nothing , Geom+ , Nothing , Geom- , Nothing ,
: Geom 5 smallrandom cells GEOMS + @ ;
\ Snowflake object description: cx cy cmomentumindex cbackground
: fly ( cx cy cmindex -- cx' cy' cmindex' ; calculate new position and momentum )
Gravitation + c@ Wind + c@ Geom + c@
dup >R
cells MOVES + @ EXECUTE
R>
;
50 0 0 BL new
10 0 0 BL new
15 0 0 BL new
20 0 0 BL new
25 0 0 BL new
30 0 0 BL new
35 0 0 BL new
40 0 0 BL new
45 0 0 BL new
9 nvariable Flakes
Flakes 9 cells + constant EndFlakes
: dosnow ( -- ; snowflake dance )
EndFlakes Flakes
DO
I @ object 4dup
>R drop at-xy R> emit \ restore background to old position
drop fly >R \ new position&momentum
2dup at-xy [CHAR] * emit \ snow paint
2dup xy@ R> swap \ get background at new position
new I ! \ make&store the new object
1 CELLS +LOOP
;
: merry-Christmas ( -- )
init-delay
page show 1
BEGIN
key? 0=
WHILE
dosnow
dup 4 mod 0= IF doo THEN
dup 30 mod 0= IF windex++ THEN
0 0 at-xy
1+
300 ms
REPEAT
drop
0 ROWS# at-xy BL EMIT
;
\ merry-Christmas
[toc] | [prev] | [next] | [standalone]
| From | Steve Graham <jsgrahamus@yahoo.com> |
|---|---|
| Date | 2015-01-07 10:44 -0800 |
| Message-ID | <m8juqt$9m0$1@speranza.aioe.org> |
| In reply to | #35175 |
> merry-Christmas bye > > --->8 > > Usage: gforth merry-christmas.fs > > I hope you enjoy the card and the little food for thought included in this forth source! > > Merry Christmas! > sincerely yours humptydumpty > Thanks for this. Steve
[toc] | [prev] | [standalone]
Back to top | Article view | comp.lang.forth
csiph-web