Kirjautuminen

Haku

Tehtävät

Keskustelu: Koodit: Tetris 8th-kielellä

Sivun loppuun

jalski [19.02.2018 07:42:58]

#

8th on moderni Forth tyylinen ohjelmointikieli, joka palauttaa käyttäjän takaisin aikakauteen jolloin ohjelmointi vielä oli addiktiivista ja kivaa.

Alla äänitukea ja pause toiminnallisuutta lukuunottamatta täysi Tetris toteutus. Nämä puutteet korjaan myöhemmin. Äänituki ei ole mukana 8th:n ilmaisessa versiossa, joten tämä versio sopinee muutenkin paremmin tänne.

\
\ Simple Tetris game written in 8th.
\
\ GUI needs work. Highscore list would be nice.
\
true app:isgui !

: BOARDWIDTH  10 ;
: BOARDHEIGHT 22 ;
: BLOCKWIDTH  20 ;
: BOARDX 20 ; \ board x-position
: BOARDY 40 ; \ board y-position
: NEXTSHAPEX 270 ;
: NEXTSHAPEY 50 ;
: STARTY -4 ;

\ possible game states
: TITLE 0 ;
: RUNGAME 1 ;
: PAUSED 2 ;
: GAMEOVER 3 ;

var gamestate

var delay
[30, 25, 20, 15, 10, 8] var, delays

{
   "cursor up"    : false,
   "cursor down"  : false,
   "cursor left"  : false,
   "cursor right" : false,
   "spacebar"     : false
} var, keys


: reset-keys
  keys @
  "cursor up" false m:!
  "cursor down" false m:!
  "cursor left" false m:!
  "cursor right" false m:!
  "spacebar" false m:!
  drop ;


: onkey
  drop
  g:keyinfo nip "desc" m:@ nip
  dup
  keys @ swap m:exists?
  if
    swap true m:! drop
  else
    2drop
  then
  true ;


["black","red","orange","yellow","green","blue","cyan","violet"] var, colors

[
\ ####
   {
     "coords" : [
                  [ { "x" : 0, "y" : 1 }, { "x" : 1, "y" : 1 }, { "x" : 2, "y" : 1 }, { "x" : 3, "y" : 1 } ],
                  [ { "x" : 1, "y" : 0 }, { "x" : 1, "y" : 1 }, { "x" : 1, "y" : 2 }, { "x" : 1, "y" : 3 } ] ],
     "points" : [ 5, 2 ],
     "color" : "red"
   },
\ ##
\ ##
   {
     "coords" : [
                  [ { "x" : 0, "y" : 0 }, { "x" : 0, "y" : 1 }, { "x" : 1, "y" : 0 }, { "x" : 1, "y" : 1 } ] ],
     "points" : [ 6 ],
     "color" : "orange"
   },
\ #
\ ##
\ #
   {
     "coords" : [
                  [ { "x" : 1, "y" : 0 }, { "x" : 0, "y" : 1 }, { "x" : 1, "y" : 1 }, { "x" : 2, "y" : 1 } ],
                  [ { "x" : 1, "y" : 0 }, { "x" : 1, "y" : 1 }, { "x" : 2, "y" : 1 }, { "x" : 1, "y" : 2 } ],
                  [ { "x" : 0, "y" : 1 }, { "x" : 1, "y" : 1 }, { "x" : 2, "y" : 1 }, { "x" : 1, "y" : 2 } ],
                  [ { "x" : 1, "y" : 0 }, { "x" : 0, "y" : 1 }, { "x" : 1, "y" : 1 }, { "x" : 1, "y" : 2 } ] ],
     "points" : [ 5, 5, 6, 5 ],
     "color" : "yellow"
   },
\ ##
\  ##
   {
     "coords" : [
                  [ { "x" : 0, "y" : 0 }, { "x" : 1, "y" : 0 }, { "x" : 1, "y" : 1 }, { "x" : 2, "y" : 1 } ],
                  [ { "x" : 1, "y" : 0 }, { "x" : 0, "y" : 1 }, { "x" : 1, "y" : 1 }, { "x" : 0, "y" : 2 } ] ],
     "points" : [ 6, 7 ],
     "color" : "green"
   },
\  ##
\ ##
   {
     "coords" : [
                  [ { "x" : 1, "y" : 0 }, { "x" : 2, "y" : 0 }, { "x" : 0, "y" : 1 }, { "x" : 1, "y" : 1 } ],
                  [ { "x" : 0, "y" : 0 }, { "x" : 0, "y" : 1 }, { "x" : 1, "y" : 1 }, { "x" : 1, "y" : 2 } ] ],
     "points" : [ 6, 7 ],
     "color" : "blue"
   },
\ ###
\ #
   {
     "coords" : [
                  [ { "x" : 2, "y" : 0 }, { "x" : 0, "y" : 1 }, { "x" : 1, "y" : 1 }, { "x" : 2, "y" : 1 } ],
                  [ { "x" : 0, "y" : 0 }, { "x" : 0, "y" : 1 }, { "x" : 0, "y" : 2 }, { "x" : 1, "y" : 2 } ],
                  [ { "x" : 0, "y" : 0 }, { "x" : 1, "y" : 0 }, { "x" : 2, "y" : 0 }, { "x" : 0, "y" : 1 } ],
                  [ { "x" : 0, "y" : 0 }, { "x" : 1, "y" : 0 }, { "x" : 1, "y" : 1 }, { "x" : 1, "y" : 2 } ] ],
     "points" : [ 6, 7, 6, 7 ],
     "color" : "cyan"
   },
\ #
\ ###
   {
     "coords" : [
                  [ { "x" : 0, "y" : 0 }, { "x" : 1, "y" : 0 }, { "x" : 2, "y" : 0 }, { "x" : 2, "y" : 1 } ],
                  [ { "x" : 1, "y" : 0 }, { "x" : 1, "y" : 1 }, { "x" : 0, "y" : 2 }, { "x" : 1, "y" : 2 } ],
                  [ { "x" : 0, "y" : 0 }, { "x" : 0, "y" : 1 }, { "x" : 1, "y" : 1 }, { "x" : 2, "y" : 1 } ],
                  [ { "x" : 0, "y" : 0 }, { "x" : 1, "y" : 0 }, { "x" : 0, "y" : 1 }, { "x" : 0, "y" : 2 } ] ],
     "points" : [ 6, 7, 6, 7 ],
     "color" : "violet"
   }
] var, shapes

var board

var shape
var x
var y
var rotation

var oldx        \ old x
var oldy        \ old y
var oldrotation \ old rotation

var nextshape
var nextx
var nextrotation

var score
var rows
var level


: init-board
  [
     [0,0,0,0,0,0,0,0,0,0],
     [0,0,0,0,0,0,0,0,0,0],
     [0,0,0,0,0,0,0,0,0,0],
     [0,0,0,0,0,0,0,0,0,0],
     [0,0,0,0,0,0,0,0,0,0],
     [0,0,0,0,0,0,0,0,0,0],
     [0,0,0,0,0,0,0,0,0,0],
     [0,0,0,0,0,0,0,0,0,0],
     [0,0,0,0,0,0,0,0,0,0],
     [0,0,0,0,0,0,0,0,0,0],
     [0,0,0,0,0,0,0,0,0,0],
     [0,0,0,0,0,0,0,0,0,0],
     [0,0,0,0,0,0,0,0,0,0],
     [0,0,0,0,0,0,0,0,0,0],
     [0,0,0,0,0,0,0,0,0,0],
     [0,0,0,0,0,0,0,0,0,0],
     [0,0,0,0,0,0,0,0,0,0],
     [0,0,0,0,0,0,0,0,0,0],
     [0,0,0,0,0,0,0,0,0,0],
     [0,0,0,0,0,0,0,0,0,0],
     [0,0,0,0,0,0,0,0,0,0],
     [0,0,0,0,0,0,0,0,0,0]
  ] const board ! ;


: new-row
  [0,0,0,0,0,0,0,0,0,0] const ;


: delete-rows
  (
    >r board @ r@ a:@
    0 ' n:= a:indexof nip
    null? if
      drop
      r@ a:-
      new-row a:slide
      drop
      rows @ n:1+ rows !
    else
      2drop
    then
    rdrop
   ) 0 BOARDHEIGHT n:1- loop ;


: canmove
  true >r
  shape @ "coords" m:@ nip
  rotation @ a:@ nip
  (
    nip
    "x" m:@ x @ n:+ dup 0 n:<
    swap 10 n:< not or
    swap
    "y" m:@ y @ n:+ 22 n:< not rot or
     if drop break else
       board @ swap
       "y" m:@
       y @ n:+
       dup
       0 n:< if
         2drop drop
       else
         swap >r
         a:@ nip
         r> "x" m:@ nip
         x @ n:+
         a:@ nip
         0 n:= not if break then
       then
     then
     break? if false rdrop >r then
  ) a:each
  drop
  r> ;


: rand7 rand-pcg n:abs 7 n:mod ;


: next-shape
  shapes @ rand7 a:@ nip dup nextshape !
  "coords" m:@ nip a:len nip
  rand-pcg n:abs swap n:mod nextrotation !
  rand7 nextx ! ;


: draw-board
   2 g:line-width
   "black" g:scolor
   board @
   (
     swap
     BLOCKWIDTH n:* BOARDY n:+
     >r
     (
       >r
       rswap
       BLOCKWIDTH n:* BOARDX n:+
       r@
       rswap
       BLOCKWIDTH
       BLOCKWIDTH
       g:rect
       colors @ r> caseof g:fcolor
       g:stroke-fill
     ) a:each
     drop
     rdrop
   ) a:each
   drop ;


: draw-shape
  2 g:line-width
  "black" g:scolor
  >r
  shape @ "color" m:@ r> swap g:fcolor swap
  "coords" m:@ nip rotation @ a:@ nip
  (
    nip "y" m:@ y @ n:+ BLOCKWIDTH n:* BOARDY n:+ dup
    BOARDY n:< not if
      swap
      "x" m:@ nip x @ n:+ BLOCKWIDTH n:* BOARDX n:+
      swap
      BLOCKWIDTH
      BLOCKWIDTH
      g:rect
    else
      2drop
    then
  ) a:each
  drop
  g:stroke-fill ;


locals:
: draw-nextshape
  4 "min-x" w:!
  4 "min-y" w:!
  0 "max-x" w:!
  0 "max-y" w:!

  nextshape @ "coords" m:@ nip nextrotation @ a:@ nip
  (
    nip
    "x" m:@ dup "max-x" w:@ n:max "max-x" w:!
    "min-x" w:@ n:min "min-x" w:!

    "y" m:@ dup "min-y" w:@ n:max "min-y" w:!
    "min-y" w:@ n:min "min-y" w:! drop
  ) a:each
  drop

  4 "max-x" w:@ "min-x" w:@ n:- n:1+ n:- BLOCKWIDTH n:* 2 n:/ "min-x" w:@ BLOCKWIDTH n:* n:- "o-x" w:!
  4 "max-y" w:@ "min-y" w:@ n:- n:1+ n:- BLOCKWIDTH n:* 2 n:/ "min-y" w:@ BLOCKWIDTH n:* n:- "o-y" w:!

  2 g:line-width
  "black" g:scolor
  "darkgray" g:fcolor
  NEXTSHAPEX 5 n:- NEXTSHAPEY 5 n:- BLOCKWIDTH 4 n:* 10 n:+ dup g:rect
  g:stroke-fill

  >r
  nextshape @ "color" m:@ r> swap g:fcolor swap
  "coords" m:@ nip nextrotation @ a:@ nip
  (
    nip "x" m:@ BLOCKWIDTH n:* NEXTSHAPEX n:+ "o-x" w:@ n:+ swap
    "y" m:@ nip BLOCKWIDTH n:* NEXTSHAPEY n:+ "o-y" w:@ n:+
    BLOCKWIDTH
    BLOCKWIDTH
    g:rect
  ) a:each
  drop
  g:stroke-fill ;


: draw-title
  draw-board
  2 g:line-width
  "black" g:scolor
  "darkgray" g:fcolor
  NEXTSHAPEX 5 n:- NEXTSHAPEY 5 n:- BLOCKWIDTH 4 n:* 10 n:+ dup g:rect
  g:stroke-fill
  "20" g:setfont
  g:l-text
  NEXTSHAPEX 8 n:- 160 "NEXT PIECE" g:draw-text-at
  NEXTSHAPEX 30 n:- 200 score @ "score: %d" s:strfmt g:draw-text-at
  NEXTSHAPEX 30 n:- 220 level @ "level: %d" s:strfmt g:draw-text-at ;


: draw-rungame
  draw-board
  draw-shape
  draw-nextshape

  "20" g:setfont
  g:l-text
  NEXTSHAPEX 8 n:- 160 "NEXT PIECE" g:draw-text-at
  NEXTSHAPEX 30 n:- 200 score @ "score: %d" s:strfmt g:draw-text-at
  NEXTSHAPEX 30 n:- 220 level @ "level: %d" s:strfmt g:draw-text-at ;


: draw-gameover
  draw-board
  draw-shape
  draw-nextshape

  "20" g:setfont
  g:l-text
  NEXTSHAPEX 8 n:- 160 "NEXT PIECE" g:draw-text-at
  NEXTSHAPEX 30 n:- 200 score @ "score: %d" s:strfmt g:draw-text-at
  NEXTSHAPEX 30 n:- 220 level @ "level: %d" s:strfmt g:draw-text-at
  "50" g:setfont
  "white" g:scolor
  g:c-text
  200 250 "GAME OVER!" g:draw-text-at ;

: ondraw
[ ' draw-title , ' draw-rungame , ' draw-rungame , ' draw-gameover ]
  gamestate @ caseof ;


: init-game
  0 score !
  1 level !
  0 rows !
  next-shape
  nextshape @ shape !
  nextrotation @ rotation !
  nextx @ x !
  STARTY y !
  next-shape
  delays @ 0 a:@ nip delay !
  init-board
  RUNGAME gamestate !
  reset-keys ;


: points?
  shape @ "points" m:@ nip rotation @ a:@ nip ;


: shape-color?
  shape @ "color" m:@ nip
  colors @ swap
  ' s:= a:indexof nip ;


: store-block  \ pointmap
  "y" m:@ y @ n:+
   dup 0 n:< if
    2drop
   else
     board @ swap a:@ nip
     swap
     "x" m:@ nip x @ n:+
     shape-color? a:!
     drop
   then ;


: gameloop
  keys @
  "cursor up"
  m:@ if
    "cursor up" false m:!
    rotation @ dup oldrotation ! n:1+ dup rotation !
    shape @ "coords" m:@ nip a:len n:1- nip
    n:> if 0 rotation ! then
    canmove not if oldrotation @ rotation ! then
  then

  "cursor left"
  m:@ if
    "cursor left" false m:!
    x @ dup oldx ! n:1- x !
    canmove not if oldx @ x ! then
  then

  "cursor right"
  m:@ if
    "cursor right" false m:!
    x @ dup oldx ! n:1+ x !
    canmove not if oldx @ x ! then
  then

  "spacebar"  \ block is dropped
  m:@ if
    "spacebar" false m:!
    repeat
      y @ n:1+ y !
      canmove
      not if break then
    again
    y @ n:1-
    y !

    shape @ "coords" m:@ nip
    rotation @ a:@ nip
    (
      nip
      store-block
    ) a:each
    drop

    score @ points? n:+ score !
    delete-rows

    y @ 0 n:< if
      GAMEOVER gamestate !
    else
      nextshape @ shape !
      nextrotation @ rotation !
      nextx @ x !
      STARTY y !
      next-shape
    then

  else  \ block falls or down cursor pressed
    "cursor down" m:@
    delay @ n:1- dup delay !
    0 n:> not or if
      "cursor down" false m:!
      y @ dup oldy ! n:1+ y !
      canmove not if
        oldy @ y !
        shape @ "coords" m:@ nip
        rotation @ a:@ nip
        (
          nip
          store-block
        ) a:each
        drop

        score @ points? n:+ score !
        delete-rows

        y @ 0 n:< if
          GAMEOVER gamestate !
        else
          nextshape @ shape !
          nextrotation @ rotation !
          nextx @ x !
          STARTY y !
          next-shape
        then
      else
        rows @ 10 n:/ int n:1+ dup level !
        0 5 n:clamp n:1-
        delays @ swap a:@ nip delay !
      then
    then
  then
  drop ;


: ontimer
  [ ' noop , ' gameloop , ' gameloop , ' noop ]
  gamestate @ caseof
  g:invalidate ;


: onMenuSelected
  n:1- [ ' init-game , ' g:quit ] case ;


var gui

{
  "kind" : "win",
  "buttons" : 5,
  "title" : "Tetris v. 0.1",
  "wide" : 400,
  "high" : 500,
  "center" : true,
  "bg" : "gray",
  "font" : "Arial 10",
  "draw" : "ondraw",
  "timer" : "ontimer",
  "key-pressed" : "onkey",
  "timer-period" : 20,
  "children" :
  [
    {
      "kind" : "menubar",
      "name" : "menu",
      "bounds" : "0,0,parent.width, parent.height/20",
      "menu-selected" : "onMenuSelected",
      "menu" :
      [
        [
          "Game", 0,
          "New game", 1,
          "Quit", 2
        ]
      ]
    }
  ]
} var, gui-desc


: app:main
  init-game
  TITLE gamestate !
  gui-desc @ g:new gui ! ;

Metabolix [19.02.2018 14:29:50]

#

Koodi on kaikkea muuta kuin selvää, joten suosittelen kommenttien lisäämistä.

jalski [19.02.2018 21:50:02]

#

Lisäsin alkuruutuun kuvan ja peliin pause toiminnallisuuden.

Päivitetty koodi ja ajettavat binäärit Windows, Linux ja macOS käyttöjärjestelmille löytyy täältä.

jalski [24.02.2018 10:03:29]

#

Lisäsin alustavan äänituen peliin. Omalla koneellani en kuitenkaan jostain syystä saa ääntä kuuluviin, vaikka mielestäni tulkitsen 8th:n manuaalia oikein.

Alla olevan linkin takana on nykyinen kehitysversio ajettavien binäärien kera Windows ja Linux käyttöjärjestelmille. Voisiko joku kokeilla johtuuko äänettömyys omasta koneestani, bugista Windows tuessa tai sitten vaan siitä, että en vaan osaa.

Eritoten kiinnostaisi Linux version toimivuus.

Löytyypi täältä.

Pessi [24.02.2018 10:30:59]

#

Ei kuulu ääniä Windows versiossa.

jalski [24.02.2018 10:44:39]

#

Pessi kirjoitti:

Ei kuulu ääniä Windows versiossa.

Kiitos! Alan kallistua sille kannalle, että windows version äänituessa on bugi. Itselläni "snd:volume?" palauttaa aina nolla, vaikka pitäisi palauttaa järjestelmän äänitaso. Lisäksi saan ääntä kuuluviin, jos laitan sen soimaan loopissa ja katkaisen soiton äänitiedoston keston jälkeen manuaalisesti. Tällöin tosin soitto lähtee vasta pienellä viiveellä ja tämä tuntuu muutenkin "tempulta", jota ei koodiin haluaisi kirjoittaa.

Linux käyttäjiä?

Metabolix [24.02.2018 12:28:49]

#

Linux-versiossa ääni kuuluu vain vasemmasta kanavasta (vaikka yleensä mono-ääni pitäisi kopioida molempiin kanaviin).

jalski [24.02.2018 15:50:53]

#

Metabolix kirjoitti:

Linux-versiossa ääni kuuluu vain vasemmasta kanavasta (vaikka yleensä mono-ääni pitäisi kopioida molempiin kanaviin).

Kiitos! Lisäsin 8th bug trackeriin huomautuksen asiasta.

Sivun alkuun

Vastaus

Aihe on jo aika vanha, joten et voi enää vastata siihen.

Tietoa sivustosta