RISC DISC 1/RISC_DISC_1.iso/pd_share/code/pascal/!Balls64/p/balls64

Text File | 1992-10-21 | 16.8 KB | 583 lines

(*
 * Title:    balls64
 * Purpose:  to demonstrate the use of the RISC OS library
 *
 * This application takes the balls64 program, which you may have seen and
 * displays it in a window. We use a sprite to hold the display, and plot
 * this sprite scaled to fit the current size of the window.
 * Left-clicking on the icon will start the display and this can be
 * "frozen/unfrozen" using the main menu. Since we are in a cooperative
 * multi-tasking environment, we display a ball on every null event to
 * avoid "hogging" the CPU
 *
 *)

Program Balls64;

Label 9999;

#include "wimp.h"        (*  access to WIMP SWIs                      *)
#include "wimpt.h"       (*  wimp task facilities                     *)
#include "win.h"         (*  registering window handlers              *)
#include "event.h"       (*  poll loops, etc                          *)
#include "baricon.h"     (*  putting icon on icon bar                 *)
#include "sprite.h"      (*  sprite operations                        *)
#include "werr.h"        (*  error reporting                          *)
#include "res.h"         (*  access to resources                      *)
#include "resspr.h"      (*  sprite resources                         *)
#include "flex.h"        (*  dynamic mem alloc from WIMP              *)
#include "template.h"    (*  reading in template file                 *)
#include "bbc.h"         (*  olde-style graphics routines             *)
#include "colourtran.h"  (*  interface to colour translation module   *)
#include "os.h"          (*  low-level RISCOS access                  *)
#include "dbox.h"        (*  dialogue box handling                    *)
#include "saveas.h"      (*  data export from dbox by icon dragging   *)
#include "visdelay.h"    (*  show the hourglass for delay             *)

(* --- Conversion macros --- *)
(* These macros convert between sprite coords and work area coords *)

#define balls64_Xtowork(x)  shl((x), 1)
#define balls64_Ytowork(y)  shl((y), 2)

(* --- Sprite Constants --- *)
#define SpriteFile   $0ff9
#define SpriteWidth  610
#define SpriteHeight 230
#define SpriteMode    15
#define SpriteSize   640*256 + size(sprite_header) + size(sprite_area)

(* --- Circle Constants --- *)
#define Radius  64
#define RadDiv2 shr(Radius, 1)
#define Step    shr(Radius, 3)

(* --- Menu Entry Constants --- *)
#define iconmenu_MInfo     1
#define iconmenu_MSave     2
#define iconmenu_MDisplay  3
#define iconmenu_MFreeze   4
#define iconmenu_MQuit     5

type spr_details =
       record
         area : sprite_area_ptr;
         id : sprite_id
       end;

type change_box_handle = ^change_box_ptr;
     change_box_ptr = ^change_box;
     change_box =
       record
         flag : integer;
         box : wimp_box
       end;

(* --- Program Globals --- *)

var my_sprite : spr_details;         (* sprite used for display      *)
    displaywin_handle : wimp_w;      (* display window handle        *)
    save_area : ^integer;            (* save area for sprite context *)

    displaying : boolean;            (* window on display?           *)
    frozen : boolean;                (* window display frozen?       *)
    xdivmult, ydivmult,
    xmagmult, ymagmult : integer;    (* scale to fit window          *)
    trans : array[0..255] of sprite_pixtrans;
                                     (* colour translation table     *)


(*************************** SPRITE CREATION *******************************)

procedure balls64_create_sprite(var my_sprite : spr_details);

var save_area_size : integer;
    ptr : sprite_ptr;

begin
  (* --- allocate our own sprite area to hold balls display --- *)

  if not flex_alloc(flex_ptr(address(my_sprite.area)), SpriteSize)
    then werr(TRUE, 'Fatal error - failed to allocate store for sprite');
  sprite_area_initialise(my_sprite.area, SpriteSize);

  (* --- create a sprite within that area --- *)

  wimpt_complain(sprite_create(my_sprite.area, 'balldisplay',
                 sprite_nopalette, SpriteWidth, SpriteHeight, SpriteMode));
  my_sprite.id.tag := sprite_id_name;
  my_sprite.id.s.name := 'balldisplay';

  (* --- select the sprite and get a pointer to it (faster) --- *)

  wimpt_complain(sprite_select_rp(my_sprite.area, address(my_sprite.id), ptr));
  my_sprite.id.tag := sprite_id_addr;
  my_sprite.id.s.addr := ptr;

  (* --- establish save area size for sprite context and allocate it --- *)
  (* --- also set save area's first word to zero to show it is not   --- *)
  (* --- yet initialised                                             --- *)

  wimpt_complain(sprite_sizeof_spritecontext(my_sprite.area,
                                             address(my_sprite.id),
                                             save_area_size));
  if not flex_alloc(flex_ptr(address(save_area)), save_area_size)
    then werr(TRUE, 'Fatal error - failed to get store for sprite context');
  save_area^ := 0;
end;

(***************************** WINDOW HANDLING *****************************)

procedure balls64_create_displaywin(var handle : wimp_w);

var window : wimp_wind_ptr;

begin

  (* --- find template for our window and create a window from it --- *)
    window := template_syshandle('ballswind');
    wimp_create_wind(window, handle);

end;

procedure balls64_redo_window(r : wimp_redrawstr; more : integer);

var more_to_do : integer;
    new_r : wimp_redrawstr;
    factors : sprite_factors;
    pixtrans : array[0..255] of sprite_pixtrans;

begin

  more_to_do := more;
  new_r := r;

  (* --- ask how the WIMP is going to scale our sprite --- *)
  wimp_readpixtrans(my_sprite.area, address(my_sprite.id),
                    address(factors), address(pixtrans[0]));

  (* -- scale the factors according to current window size --- *)
  factors.xdiv := factors.xdiv * xdivmult;
  factors.ydiv := factors.ydiv * ydivmult;
  factors.xmag := factors.xmag * xmagmult;
  factors.ymag := factors.ymag * ymagmult;

  (* --- refresh the window's contents --- *)
  while more_to_do <> 0
    do begin
         wimpt_complain(sprite_put_scaled(my_sprite.area,
                                          address(my_sprite.id), 0,
                                          r.box.x0, r.box.y0,
                                          address(factors),
                                          address(trans[0])));
         wimp_get_rectangle(address(new_r), more_to_do);
       end;
end;

procedure balls64_redraw_window(handle : wimp_w);

var more : integer;
    r : wimp_redrawstr;
    winfo : wimp_winfo;

begin

  winfo.w := handle;
  wimp_get_wind_info(address(winfo));

  (* --- establish factors by which to scale sprite from current --- *)
  (* --- window size                                             --- *)
  xdivmult := winfo.info.ex.x1 - winfo.info.ex.x0;
  ydivmult := winfo.info.ex.y1 - winfo.info.ex.y0;
  xmagmult := winfo.info.box.x1 - winfo.info.box.x0;
  ymagmult := winfo.info.box.y1 - winfo.info.box.y0;

  (* --- do the redraw --- *)
  r.w := handle;
  wimp_redraw_wind(address(r), more);

  if (more <> 0)
    then balls64_redo_window(r, more);
end;

procedure balls64_update_window(r : wimp_redrawstr);

var new_r : wimp_redrawstr;
    more : integer;

begin

  new_r := r;

  wimp_update_wind(address(new_r), more);
  if (more <> 0)
    then balls64_redo_window(new_r, more);
end;

var old_x, old_y : integer;

procedure balls64_open_window(o : wimp_openstr_ptr);

begin

  (* --- force scroll offsets to 0, since the window always --- *)
  (* --- represents the whole display                       --- *)
  o^.x := 0;
  o^.y := 0;

  wimp_open_wind(o);

  (* --- only do a redraw if the size of the window has changed --- *)
  if (old_x <> (o^.box.x1 - o^.box.x0)) or
     (old_y <> (o^.box.y1 - o^.box.y0))
    then begin
           balls64_redraw_window(o^.w);
           old_x := o^.box.x1 - o^.box.x0;
           old_y := o^.box.y1 - o^.box.y0;
         end;
end;

procedure balls64_leftclickproc(i : wimp_i);

var state : wimp_wstate;
    r : wimp_redrawstr;

begin

  if not displaying
    then begin
           (* --- open the window we created --- *)
           wimpt_noerr(wimp_get_wind_state(displaywin_handle, address(state)));
           state.o.behind := -1;  (* make sure it is opened in front *)
           balls64_open_window(address(state.o));

           (* --- force a redraw of the whole window --- *)
           r.w := displaywin_handle;
           r.box.x0 := 0;
           r.box.x1 := balls64_Xtowork(SpriteWidth);
           r.box.y0 := -balls64_Ytowork(SpriteHeight);
           r.box.y1 := 0;
           wimp_force_redraw(address(r));
           displaying := TRUE;
         end;
end;

(************************** THE APPLICATION ITSELF *************************)

procedure balls64_changedbox(flag : integer; cbox : change_box_handle);

begin
  swi('OS_ChangedBox', [0], flag; [1], cbox^);
end;

function rand : integer; extern;

const RAND_MAX = $7fffffff;

function balls64_rnd(v : integer) : integer;

begin
  balls64_rnd := trunc((rand / RAND_MAX) * v) + 1
end;

function balls64_fnx : integer;

begin
  balls64_fnx := balls64_rnd(balls64_Xtowork(SpriteWidth))
end;

function balls64_fny : integer;

begin
  balls64_fny := balls64_rnd(balls64_Ytowork(SpriteHeight))
end;

function balls64_fnrgb : integer;

begin
  balls64_fnrgb := (balls64_rnd(3)-1)*1 +
                   (balls64_rnd(3)-1)*4 +
                   (balls64_rnd(3)-1)*16
end;

procedure balls64_do_ball;

var state : sprite_state;
    r : wimp_redrawstr;
    cbox : change_box_ptr;
    l : real;
    t, x : integer;
    base : integer;
    orgx, orgy : integer;

begin

  (* --- redirect VDU output to the sprite saving old state --- *)
  wimpt_complain(sprite_outputtosprite(my_sprite.area,
                                       address(my_sprite.id),
                                       save_area,
                                       address(state)));
  (* --- enable checking changes to the "screen" (really our sprite) --- *)
  balls64_Changedbox(1, address(cbox));
  balls64_Changedbox(2, address(cbox));

  orgx := balls64_fnx;
  orgy := balls64_fny;
  l := ln(512/Radius)/ln(2);
  base := balls64_fnrgb;
  x := Radius;
  while x >= Step
    do begin
         t := trunc(l);
         bbc_vduq(23, 17, 2, 512-shl(x, t), 0, 0, 0, 0, 0);
         if x <= RadDiv2
           then bbc_gcol(0, base+$15)
           else bbc_gcol(0,base);
         bbc_move(orgx - x div 3,orgy - x div 3);
         bbc_plot($9D, orgx+x, orgy);
         x := x - Step;
       end;

  (* --- see what's changed on the "screen" (ie. our sprite) --- *)
  balls64_Changedbox(-1, address(cbox));

  r.w := displaywin_handle;
  r.box.x0 := balls64_Xtowork(cbox^.box.x0) * xmagmult div xdivmult
               - balls64_Xtowork(1);
  r.box.x1 := balls64_Xtowork(cbox^.box.x1) * xmagmult div xdivmult
               + balls64_Xtowork(1);
  r.box.y0 := balls64_Ytowork(cbox^.box.y0 - SpriteHeight)
               * ymagmult div ydivmult - balls64_Ytowork(1);
  r.box.y1 := balls64_Ytowork(cbox^.box.y1 - SpriteHeight)
               * ymagmult div ydivmult + balls64_Ytowork(1);

  (* --- restore output back to the VDU screen --- *)
  wimpt_complain(sprite_restorestate(state));

  (* --- update the window contents --- *)
  balls64_update_window(r);
end;

(****************************** EVENT HANDLING *****************************)

var bpp_reported : boolean;

procedure balls64_bpp_warn;

begin
  if not bpp_reported
    then begin
           werr(FALSE, 'Warning: I only look my best in 8-bpp modes');
           bpp_reported := TRUE;
         end;
end;

procedure balls64_handler(e : wimp_eventstr_ptr; handle : pointer);

begin

  case e^.e of
    wimp_ENULL:
      if not frozen and displaying
        then balls64_do_ball;

    wimp_EREDRAW:
      balls64_redraw_window(e^.data.o.w);

    wimp_EOPEN:
      balls64_open_window(address(e^.data.o));

    wimp_ECLOSE:
      begin
        wimpt_noerr(wimp_close_wind(e^.data.o.w));
        displaying := FALSE;
      end;

    wimp_ESEND,
    wimp_ESENDWANTACK:     (*
                            * this code checks for mode/palette
                            * broadcasts
                            *)
      case e^.data.msg.hdr.action of
        wimp_PALETTECHANGE:
          wimpt_complain(colourtran_select_table(SpriteMode,
                         nil, -1,
                         wimp_paletteword_ptr(-1), address(trans)));

        wimp_MMODECHANGE:
          begin
            wimpt_checkmode;
            if wimpt_bpp <> 8
              then balls64_bpp_warn;
            wimpt_complain(colourtran_select_table(SpriteMode,
                          nil, -1,
                          wimp_paletteword_ptr(-1), address(trans)));
          end;


        wimp_MHELPREQUEST:
          begin
            e^.data.msg.hdr.your_ref := e^.data.msg.hdr.my_ref;
            e^.data.msg.hdr.action := wimp_MHELPREPLY;
            e^.data.msg.hdr.size := 256;
            if e^.data.msg.helprequest.m.i = -1 (*ie. not on our icon*)
              then e^.data.msg.helpreply.text :=
                    'This is the balls64 display.|MOnly one can be active'
              else e^.data.msg.helpreply.text :=
                    'This is the balls64 icon.|MClick SELECT to start display';
            wimpt_noerr(wimp_sendmessage(wimp_ESEND, address(e^.data.msg),
                                         e^.data.msg.hdr.task));
          end;
    end;

  end;
end;

procedure balls64_info_aboutprog;

var d : dbox;

begin

  (* --- display info about the program in a dialogue box --- *)
  d := dbox_new('ProgInfo');

  dbox_showstatic(d);

  dbox_fillin(d);

  dbox_dispose(d);
end;

function balls64_saver(filename : string; handle : pointer) : boolean;

var e : os_error;

begin

  (* --- save the sprite area in a sprite file --- *)
  visdelay_begin;
  e := wimpt_complain(sprite_area_save(my_sprite.area, filename));
  visdelay_end;

  balls64_saver := not e;
end;

(******************************* MENU HANDLING *****************************)

function balls64_menumaker(handle : pointer) : menu;

var temp : menu;

begin

  (* --- create a menu for the icon on the icon bar --- *)
  temp := menu_new('Balls64', '>Info,>Save,Display,Freeze,Quit');

  (* --- fade out "start" field if we already have balls on display --- *)
  menu_setflags(temp, iconmenu_MDisplay, false, displaying);

  (* --- tick/untick "freeze" appropriately --- *)
  menu_setflags(temp, iconmenu_MFreeze, frozen, false);

  balls64_menumaker := temp
end;

procedure balls64_menuproc(handle : pointer; hit : event_hitstr_ptr);

begin
  (* --- see which menu entry has been chosen --- *)
  case integer(hit^[0]) of
    iconmenu_MInfo:
      balls64_info_aboutprog;

    iconmenu_MDisplay:
        balls64_leftclickproc(wimp_i(0));

    iconmenu_MSave:
        saveas(SpriteFile, 'BallsDump', SpriteSize,
               balls64_saver, nil, nil, nil);

    iconmenu_MFreeze:
      if (frozen)
        then begin
               event_setmask(uand(event_getmask, unot(wimp_EMNULL)));
               frozen := FALSE;
             end
        else begin
               event_setmask(uor(event_getmask, wimp_EMNULL));
               frozen := TRUE;
             end;

    iconmenu_MQuit:
        goto 9999;

  end;
end;

(******************************** INITIALISATION ***************************)

procedure balls64_initialise;

begin
  (* --- initialise wimp library modules --- *)
  wimpt_init('balls64');
  res_init('balls64');
  resspr_init;
  flex_init;
  template_init;
  dbox_init;

  (* --- check which mode we are in --- *)
  wimpt_checkmode;
  if (wimpt_bpp <> 8)
    then balls64_bpp_warn;

  (* --- create sprite to be used as output --- *)
  balls64_create_sprite(my_sprite);

  (* --- create a window for display --- *)
  balls64_create_displaywin(displaywin_handle);

  (* --- attach an event handling function to window --- *)
  win_register_event_handler(displaywin_handle, balls64_handler, nil);

  (* --- make the window we just created get delivered null events --- *)
  (* --- and also unknown events (ie. msgs for palette/mode change --- *)
  win_claim_idle_events(displaywin_handle);
  win_claim_unknown_events(displaywin_handle);

  (* --- put our icon on the icon bar --- *)
  baricon('!balls64', integer(resspr_area), balls64_leftclickproc);

  (* --- attach a menu to the icon on the icon bar --- *)
  event_attachmenumaker(win_ICONBAR, balls64_menumaker, balls64_menuproc, nil);

  (* --- read the palette --- *)
  wimpt_complain(colourtran_select_table(SpriteMode,nil,-1,
                           wimp_paletteword_ptr(-1),address(trans)));

  (* --- activate saving of floating point registers on poll --- *)
  wimp_save_fp_state_on_poll;
end;

(******************************* MAIN PROGRAM ******************************)

begin
  old_x := 0;
  old_y := 0;
  displaying := false;
  frozen := false;
  bpp_reported := false;
  (* --- initialise the environment --- *)
  balls64_initialise;

  (* --- mask off the events we're not interested in --- *)
  event_setmask(uor(wimp_EMPTRENTER, wimp_EMPTRLEAVE));

  (* --- the main event loop --- *)
  while(TRUE)
    do event_process;
  9999:;
end.