--
--	mrstar8.occ -- sdlraster starfall demo (8 star version)
--	Copyright (C) 2005-2006 Fred Barnes <frmb@kent.ac.uk>
--	Copyright (C) 2007  University of Kent
--
--	This program is free software; you can redistribute it and/or
--	modify it under the terms of the GNU General Public License as
--	published by the Free Software Foundation, either version 2 of the
--	License, or (at your option) any later version.
--
--	This program is distributed in the hope that it will be useful,
--	but WITHOUT ANY WARRANTY; without even the implied warranty of
--	MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
--	General Public License for more details.
--
--	You should have received a copy of the GNU General Public License
--	along with this program.  If not, see
--	<http://www.gnu.org/licenses/>.
--

--{{{  includes
#INCLUDE "sdlraster.module"
#INCLUDE "course.module"
#INCLUDE "maths.module"

--}}}
--{{{  constants/types
VAL [4]BYTE bblack.pixel IS [#00,#00,#00,#00]:
VAL [4]BYTE bwhite.pixel IS [#FF,#FF,#FF,#00]:
VAL [4]BYTE bred.pixel IS [#00,#FF,#00,#00]:
VAL [4]BYTE bgreen.pixel IS [#00,#00,#FF,#00]:
VAL [4]BYTE bblue.pixel IS [#FF,#00,#00,#00]:
VAL INT black.pixel RETYPES bblack.pixel:
VAL INT white.pixel RETYPES bwhite.pixel:
VAL INT red.pixel RETYPES bred.pixel:
VAL INT green.pixel RETYPES bgreen.pixel:
VAL INT blue.pixel RETYPES bblue.pixel:

DATA TYPE STAR.UPDATE
  RECORD
    INT x:
    INT y:
    INT size:
    INT pixel:
:

VAL INT track.length IS 96:
--}}}
--{{{  BOOL FUNCTION "=" (VAL [4]BYTE first, VAL [4]BYTE second)
BOOL FUNCTION "=" (VAL [4]BYTE first, VAL [4]BYTE second)
  VAL INT f RETYPES first:
  VAL INT s RETYPES second:
  VALOF
    SKIP
    RESULT (f = s)
:
--}}}
--{{{  [4]BYTE FUNCTION "+" (VAL [4]BYTE first, VAL [4]BYTE second)
[4]BYTE FUNCTION "+" (VAL [4]BYTE first, VAL [4]BYTE second)
  [4]BYTE r:
  VALOF
    SEQ i = 0 FOR 4
      IF
        (first[i] PLUS second[i]) < first[i]
          r[i] := #FF
        TRUE
          r[i] := (first[i] PLUS second[i])
    RESULT r
:
--}}}
--{{{  [4]BYTE FUNCTION "-" (VAL [4]BYTE first, VAL [4]BYTE second)
[4]BYTE FUNCTION "-" (VAL [4]BYTE first, VAL [4]BYTE second)
  [4]BYTE r:
  VALOF
    SEQ i = 0 FOR 4
      IF
        (first[i] MINUS second[i]) > first[i]
          r[i] := #00
        TRUE
          r[i] := (first[i] MINUS second[i])
    RESULT r
:
--}}}
--{{{  [4]BYTE FUNCTION "/" (VAL [4]BYTE data, VAL INT m)
[4]BYTE FUNCTION "/" (VAL [4]BYTE data, VAL INT m)
  [4]BYTE r:
  VALOF
    SEQ i = 0 FOR 4
      IF
        data[i] = #00
          r[i] := #00
        TRUE
          r[i] := (data[i] / (BYTE m))
    RESULT r
:
--}}}
--{{{  PROC blankglyph (RASTER r, VAL INT x, y, VAL INT size)
PROC blankglyph (RASTER r, VAL INT x, y, VAL INT size)
  SEQ oy = (y - (size / 2)) FOR size
    SEQ ox = (x - (size / 2)) FOR size
      r[oy][ox] := 0
:
--}}}
--{{{  PROC starglyph (RASTER r, VAL INT x, y, VAL INT size, VAL [4]BYTE pixel)
PROC starglyph (RASTER r, VAL INT x, y, VAL INT size, VAL [4]BYTE pixel)
  VAL [4][4]BYTE bpa IS [pixel, pixel - [#20,#40,#30,#00 (BYTE)],
                        pixel - [#40,#60,#40,#00 (BYTE)], pixel - [#60,#80,#50,#00 (BYTE)]]:
  VAL [1][1]INT glyph.1 IS [[0]]:
  VAL [2][2]INT glyph.2 IS [[0,0],
                            [0,0]]:
  VAL [3][3]INT glyph.3 IS [[1,0,1],
                            [0,0,0],
                            [1,0,1]]:
  VAL [4][4]INT glyph.4 IS [[2,1,1,2],
                            [1,0,0,1],
                            [1,0,0,1],
                            [2,1,1,2]]:
  VAL [5][5]INT glyph.5 IS [[3,2,0,2,3],
                            [2,1,0,1,2],
                            [0,0,0,0,0],
                            [2,1,0,1,2],
                            [3,2,0,2,3]]:
  VAL [6][6]INT glyph.6 IS [[3,2,0,0,2,3],
                            [2,2,0,0,2,2],
                            [0,0,0,0,0,0],
                            [0,0,0,0,0,0],
                            [2,2,0,0,2,2],
                            [3,2,0,0,2,3]]:
  VAL [4]BYTE bpixel.unknown IS [#FF,#FF,#FF,#00]:

  VAL [4]INT pa RETYPES bpa:
  VAL INT pixel.unknown RETYPES bpixel.unknown:
  CASE size
    1
      r[y][x] := pa[glyph.1[0][0]]
    2
      VAL INT oy IS (y - 1):
      VAL INT ox IS (x - 1):
      SEQ vy = 0 FOR 2
        SEQ vx = 0 FOR 2
          r[oy+vy][ox+vx] := pa[glyph.2[vy][vx]]
    3
      VAL INT oy IS (y - 1):
      VAL INT ox IS (x - 1):
      SEQ vy = 0 FOR 3
        SEQ vx = 0 FOR 3
          r[oy+vy][ox+vx] := pa[glyph.3[vy][vx]]
    4
      VAL INT oy IS (y - 2):
      VAL INT ox IS (x - 2):
      SEQ vy = 0 FOR 4
        SEQ vx = 0 FOR 4
          r[oy+vy][ox+vx] := pa[glyph.4[vy][vx]]
    5
      VAL INT oy IS (y - 2):
      VAL INT ox IS (x - 2):
      SEQ vy = 0 FOR 5
        SEQ vx = 0 FOR 5
          r[oy+vy][ox+vx] := pa[glyph.5[vy][vx]]
    6
      VAL INT oy IS (y - 3):
      VAL INT ox IS (x - 3):
      SEQ vy = 0 FOR 5
        SEQ vx = 0 FOR 5
          r[oy+vy][ox+vx] := pa[glyph.6[vy][vx]]
    ELSE
      SEQ oy = (y - (size / 2)) FOR size
        SEQ ox = (x - (size / 2)) FOR size
          r[oy][ox] := pixel.unknown
:
--}}}
--{{{  PROC starfall (VAL INT x, y, size, pixel, inertia, VAL REAL64 i.y, VAL INT stop.y, stop.x, SHARED CHAN STAR.UPDATE out!, SHARED CHAN INT rand.in?)
PROC starfall (VAL INT x, y, size, pixel, inertia, VAL REAL64 i.y, VAL INT stop.y, stop.x,
                SHARED CHAN STAR.UPDATE out!, SHARED CHAN INT rand.in?)
  STAR.UPDATE pos:
  INITIAL INT pixel IS pixel:
  INITIAL REAL64 v.y IS REAL64 TRUNC y:
  INITIAL INT y IS y:
  INITIAL INT x IS x:
  INITIAL INT inertia IS inertia:
  INT f.delay:
  SEQ
    pos[x] := x
    pos[y] := y
    pos[size] := size
    pos[pixel] := pixel

    CLAIM rand.in?
      rand.in ? f.delay

    CLAIM out!
      SEQ i = 0 FOR 2
        out ! pos

    WHILE ((y < stop.y) AND (NOT (pixel = black.pixel))) AND ((x > 10) AND (x < stop.x))
      INT t:
      TIMER tim:
      SEQ
        -- clear old
        pos[pixel] := black.pixel
        CLAIM out!
          SEQ
            out ! pos
            -- draw new
            v.y := (v.y + i.y)
            y := INT ROUND v.y
            pos[x] := x
            pos[y] := y
            pos[pixel] := pixel
            out ! pos
        tim ? t
        x := x + inertia
        pixel := pixel - (white.pixel / 128)
        IF
          (inertia > 0) AND ((y /\ #01) = 0)
            inertia := inertia - 1
          (inertia < 0) AND ((y /\ #01) = 0)
            inertia := inertia + 1
          TRUE
            SKIP
        tim ? AFTER (t PLUS f.delay)
    -- clear old
    pos[pixel] := black.pixel
    CLAIM out!
      SEQ i = 0 FOR 2
        out ! pos
:
--}}}
--{{{  PROC starloop (VAL INT i.x, i.y, i.width, i.height, t.start.pos, max.y, max.x, CHAN OF RASTER in?, out!, SHARED CHAN STAR.UPDATE upd.out!, SHARED CHAN INT rand.in?, VAL BOOL reverse)
PROC starloop (VAL INT i.x, i.y, i.width, i.height, t.start.pos, max.y, max.x,
                CHAN OF RASTER in?, out!, SHARED CHAN STAR.UPDATE upd.out!, SHARED CHAN INT rand.in?,
                VAL BOOL reverse)
  INITIAL INT x IS i.x:
  INITIAL INT y IS i.y:
  VAL REAL64 y.dist IS REAL64 TRUNC i.height:
  VAL REAL64 x.dist IS REAL64 TRUNC i.width:
  [track.length]INT x.pos:
  [track.length]INT y.pos:
  [track.length]INT star.size:
  RASTER r:
  VAL INT colour.track.length IS 18:
  VAL INT colour.track.step IS 4:
  VAL [colour.track.length][4]BYTE bl.pa IS [[#F0,#A0,#60,#00],[#E0,#B0,#50,#00],
                                            [#D0,#C0,#40,#00],[#B0,#D0,#30,#00],
                                            [#A0,#F0,#30,#00],[#90,#F0,#60,#00],
                                            [#80,#D0,#80,#00],[#60,#B0,#A0,#00],
                                            [#40,#A0,#C0,#00],[#30,#80,#C0,#00],
                                            [#30,#60,#F0,#00],[#40,#40,#F0,#00],
                                            [#60,#30,#D0,#00],[#80,#30,#B0,#00],
                                            [#80,#40,#90,#00],[#A0,#60,#80,#00],
                                            [#A0,#70,#70,#00],[#C0,#88,#68,#00]]:
  VAL [colour.track.length]INT l.pa RETYPES bl.pa:
  INT colour.pos:
  SEQ
    --{{{  intiailise the track
    REAL64 theta, step:
    INT isdl:
    SEQ
      theta := 0.0
      step := (2.0 * DPI) / (REAL64 TRUNC track.length)
      isdl := 0
      WHILE (theta < (2.0 * DPI)) AND (isdl < track.length)
        SEQ
          IF
            reverse
              VAL REAL64 theta IS ((2.0 * DPI) - theta):
              SEQ
                x.pos[isdl] := INT ROUND ((REAL64 TRUNC x) + (x.dist * DSIN (theta)))
                y.pos[isdl] := INT ROUND ((REAL64 TRUNC y) - (y.dist * DCOS (theta)))
            TRUE
              SEQ
                x.pos[isdl] := INT ROUND ((REAL64 TRUNC x) + (x.dist * DSIN (theta)))
                y.pos[isdl] := INT ROUND ((REAL64 TRUNC y) - (y.dist * DCOS (theta)))
          star.size[isdl] := INT ROUND (3.5 - (2.5 * DCOS (theta)))
          theta := (theta + step)
          isdl := (isdl + 1)
    colour.pos := 0
    --}}}  
    FORKING
      --{{{  start animating
      INITIAL INT track.pos IS t.start.pos:
      INITIAL INT next IS (t.start.pos + 1):
      INITIAL INT vcount IS 0:
      INT prev, before:
      WHILE TRUE
        SEQ
          VAL INT old.x IS x.pos[track.pos]:
          VAL INT old.y IS y.pos[track.pos]:
          VAL INT old.size IS star.size[track.pos]:
          VAL INT new.x IS x.pos[next]:
          VAL INT new.y IS y.pos[next]:
          VAL INT new.size IS star.size[next]:
          SEQ v = 0 FOR 2
            SEQ
              in ? r
              blankglyph (r, old.x, old.y, old.size)
              -- starglyph (r, new.x, new.y, new.size, l.pa[colour.pos])
              starglyph (r, new.x, new.y, new.size, bwhite.pixel)
              out ! r
          prev := track.pos
          before := ((prev + track.length) - 1) \ track.length
          track.pos := next
          IF
            vcount = 0
              REAL64 fs:
              INT inertia:
              SEQ
                fs := 1.0 + ((REAL64 TRUNC y.pos[next]) / (REAL64 TRUNC i.height))
                inertia := (x.pos[prev] - x.pos[before]) / 2
                -- fs := 0.86 + ((REAL64 TRUNC star.size[next]) / 6.0)
                -- fall.out ! x.pos[next]; y.pos[next]; star.size[next]; l.pa[colour.pos]; fs
                FORK starfall (x.pos[next], y.pos[next], star.size[next], l.pa[colour.pos],
                                inertia, fs, max.y, max.x, upd.out!, rand.in?)
                colour.pos := ((colour.pos + 1) \ colour.track.length)
                vcount := 1
            TRUE
              vcount := 0
          next := ((track.pos + 1) \ track.length)
      --}}}  
:
--}}}
--{{{  PROC fall.queue (CHAN STAR.UPDATE in?, CHAN BOOL req?, CHAN INT resp!, CHAN STAR.UPDATE out!)
PROC fall.queue (CHAN STAR.UPDATE in?, CHAN BOOL req?, CHAN INT resp!, CHAN STAR.UPDATE out!)
  VAL INT queue.size IS 4096:
  [queue.size]STAR.UPDATE holding:
  INITIAL INT num.holding IS 0:
  WHILE TRUE
    PRI ALT
      --{{{  update request
      BOOL any:
      req ? any
        SEQ
          resp ! num.holding
          SEQ i = 0 FOR num.holding
            out ! holding[i]
          num.holding := 0
      --}}}
      --{{{  not full and incoming data
      (num.holding < queue.size) & in ? holding[num.holding]
        num.holding := num.holding + 1
      --}}}
      --{{{  full and incoming data
      STAR.UPDATE temp:
      in ? temp
        SKIP
      --}}}
:
--}}}
--{{{  PROC raster.merge (CHAN RASTER in?, out!, CHAN BOOL req!, CHAN INT resp?, CHAN STAR.UPDATE upd?)
PROC raster.merge (CHAN RASTER in?, out!, CHAN BOOL req!, CHAN INT resp?, CHAN STAR.UPDATE upd?)
  RASTER r:
  STAR.UPDATE tmp:
  WHILE TRUE
    INT n:
    SEQ
      in ? r
      req ! TRUE
      resp ? n
      SEQ i = 0 FOR n
        SEQ
          upd ? tmp
          IF
            tmp[pixel] = black.pixel
              blankglyph (r, tmp[x], tmp[y], tmp[size])
            TRUE
              VAL [4]BYTE pix RETYPES tmp[pixel]:
              starglyph (r, tmp[x], tmp[y], tmp[size], pix)
      out ! r
:
--}}}
--{{{  PROC mrstar.proper (CHAN RASTER raster.in?, raster.out!, CHAN BYTE out!)
PROC mrstar.proper (CHAN RASTER raster.in?, raster.out!, CHAN BYTE out!)
  INITIAL BOOL running IS TRUE:
  RASTER r:
  INT r.w, r.h, t:
  TIMER tim:
  INT seed, v:
  SEQ
    raster.in ? r
    r.h := SIZE r
    r.w := SIZE r[0]

    out.string ("raster height = ", 0, out!)
    out.int (SIZE r, 0, out!)
    out.string (", raster width = ", 0, out!)
    out.int (SIZE r[0], 0, out!)
    out.string ("*n", 0, out!)

    tim ? t
    seed := (t >> 2) + 1

    VAL INT N.STARS IS 8:
    [N.STARS + 1]CHAN RASTER link:
    VAL [N.STARS]INT i.x IS [i = 0 FOR N.STARS | (r.w / 2)]:
    VAL [N.STARS]INT i.y IS [i = 0 FOR N.STARS | 40]:
    VAL INT r.hstep IS r.w / 32:
    VAL [N.STARS]INT i.width IS [120,110,100,90,80,70,60,140]:
    VAL [N.STARS]INT i.height IS [35,32,28,25,25,28,32,35]:
    VAL [N.STARS]INT i.start IS [0,12,24,36,48,60,72,84]:
    SHARED CHAN STAR.UPDATE updc:
    CHAN RASTER from.merge:
    CHAN BOOL b.req:
    CHAN INT b.resp:
    CHAN STAR.UPDATE updated:
    SHARED CHAN INT rand.nos:
    PAR
      --{{{  starloop processes
      PAR i = 0 FOR N.STARS
        starloop (i.x[i], i.y[i], i.width[i], i.height[i], i.start[i], r.h - 10, r.w - 10,
                  link[i]?, link[i+1]!, updc!, rand.nos?, ((i \ 2) = 0))
      --}}}

      CHAN RASTER from.last? IS link[N.STARS]?:
      raster.merge (from.last?, from.merge!, b.req!, b.resp?, updated?)

      CLAIM updc?
        fall.queue (updc?, b.req?, b.resp!, updated!)

      CHAN RASTER to.first! IS link[0]!:
      --{{{  loop
      WHILE running
        --INT x, y, c:
        SEQ

          --SEQ j = 0 FOR 2
	  --  SEQ
  	  --    x, seed := random (r.w, seed)
	  --    y, seed := random (r.h, seed)
	  --    c, seed := random ((1 << 24), seed)

	  --    r[y][x] := c

          to.first ! r
	  t := t PLUS 20000
	  tim ? AFTER t
	  from.merge ? r
          raster.out ! r
	  raster.in ? r

          -- running := FALSE
      --}}}

      --{{{  random number process
      TIMER tim:
      INT s:
      SEQ
        tim ? s
        s := (s >> 2) + 1
        CLAIM rand.nos!
          WHILE TRUE
            INT v:
            SEQ
              v, s := random (4, s)
              rand.nos ! 15000 + (v * 10)
      --}}}
:
--}}}
--{{{  PROC mrstar8 (CHAN BYTE kyb?, scr!, err!)
PROC mrstar8 (CHAN BYTE kyb?, scr!, err!)
  VAL INT width IS 320:
  VAL INT height IS 400:
  VAL INT nbufs IS 32:
  SEQ
    CHAN RASTER c, d:
    CHAN RASTER.EVENT events:
    CHAN INT control:
    PAR
      raster.display.simple ("mrstar8", width, height, nbufs, d?, c!)
      mrstar.proper (c?, d!, scr!)
:

--}}}
