Keskustelu: Ohjelmointikysymykset: Limbo: PortablE

OPT POINTER
MODULE 'gadtools'
MODULE 'exec/ports'
MODULE 'graphics/text'
MODULE 'intuition/intuition'
MODULE 'intuition/screens'
MODULE 'libraries/gadtools'
MODULE 'exec', 'graphics', 'intuition', 'utility/tagitem'

ENUM ERR_NONE, ERR_FONT, ERR_GAD, ERR_KICK, ERR_LIB, ERR_PUB, ERR_VIS, ERR_WIN

RAISE ERR_FONT IF OpenFont()=NIL,
      ERR_GAD  IF CreateGadgetA()=NIL,
      ERR_KICK IF KickVersion()=FALSE,
      ERR_LIB  IF OpenLibrary()=NIL,
      ERR_PUB  IF LockPubScreen()=NIL,
      ERR_VIS  IF GetVisualInfoA()=NIL,
      ERR_WIN  IF OpenWindowTagList()=NIL

-> Gadget ENUM to be used as GadgetIDs.
ENUM MYGAD_BUTTON

DEF topaz80:PTR TO textattr


PROC handleGadgetEvent(gad:PTR TO gadget)
  DEF id
  id:=gad.gadgetid
  SELECT id

  CASE MYGAD_BUTTON
    -> Buttons report GADGETUP's
    Print('Ouch!\n')
  ENDSELECT
ENDPROC


-> Function to handle vanilla keys.
PROC handleVanillaKey(code)
  SELECT 128 OF code
  CASE "h", "H"
    -> Button
	Print('Ouch!\n')
  ENDSELECT
ENDPROC


PROC createButtonGadget(glistptr:ARRAY OF PTR TO gadget, vi:ARRAY, topborder)
  DEF gad:PTR TO gadget, ng:PTR TO newgadget

  -> The following operation is required of any program that uses GadTools.
  -> It gives the toolkit a place to stuff context data.
  gad:=CreateContext(glistptr)

  ng:=[50, (5+topborder) !!INT,  200, 24, '_Hit me   ', topaz80, MYGAD_BUTTON, 0, vi, NILA]:newgadget
  gad:=CreateGadgetA(BUTTON_KIND, gad, ng, [GT_UNDERSCORE, "_", NIL]:tagitem)
ENDPROC gad


-> Standard message handling loop with GadTools message handling functions
-> used (Gt_GetIMsg() and Gt_ReplyIMsg()).
PROC process_window_events(mywin:PTR TO window)
  DEF imsg:PTR TO intuimessage, imsgClass, imsgCode, gad:PTR TO gadget, terminated
  terminated:=FALSE
  REPEAT
    Wait(Shl(1, mywin.userport.sigbit))

    -> Gt_GetIMsg() returns an IntuiMessage with more friendly information for
    -> complex gadget classes.  Use it wherever you get IntuiMessages where
    -> using GadTools gadgets.
    WHILE (terminated=FALSE) AND (imsg:=Gt_GetIMsg(mywin.userport))

      gad:=imsg.iaddress

      imsgClass:=imsg.class
      imsgCode:=imsg.code

      -> Use the toolkit message-replying function here...
      Gt_ReplyIMsg(imsg)

      SELECT imsgClass
        ->  --- WARNING --- WARNING --- WARNING --- WARNING --- WARNING ---
        -> GadTools puts the gadget address into IAddress of IDCMP_MOUSEMOVE
        -> messages.  This is NOT true for standard Intuition messages,
        -> but is an added feature of GadTools.

      CASE IDCMP_GADGETUP
        handleGadgetEvent(gad)

      CASE IDCMP_VANILLAKEY
        handleVanillaKey(imsgCode)

      CASE IDCMP_CLOSEWINDOW
        terminated:=TRUE

      CASE IDCMP_REFRESHWINDOW
        -> With GadTools, the application must use Gt_BeginRefresh()
        -> where it would normally have used BeginRefresh()
        Gt_BeginRefresh(mywin)
        Gt_EndRefresh(mywin, TRUE)

      ENDSELECT
    ENDWHILE
  UNTIL terminated
ENDPROC


-> Prepare for using GadTools, set up gadgets and open window.
-> Clean up and when done or on error.
PROC gadtoolsWindow()
  DEF font:PTR TO textfont, mysc:PTR TO screen, mywin:PTR TO window, glist[1]:ARRAY OF PTR TO gadget
  DEF vi:ARRAY, topborder

  font:=NIL
  mywin:=NIL
  glist[0] := NIL

  -> Open topaz 8 font, so we can be sure it's openable when we later
  -> set ng.textattr to Topaz80:
  topaz80:=['topaz.font', 8, 0, 0]:textattr
  font:=OpenFont(topaz80)
  mysc:=LockPubScreen(NILA)
  vi:=GetVisualInfoA(mysc, [NIL]:tagitem)

  -> Here is how we can figure out ahead of time how tall the window's
  -> title bar will be:
  topborder:=mysc.wbortop+mysc.font.ysize+1

  createButtonGadget(glist, vi, topborder)

  mywin:=OpenWindowTagList(NIL,
                     [WA_TITLE, 'GadTools Button Demo',
                      WA_GADGETS,   glist[0],  WA_AUTOADJUST,    TRUE,
                      WA_WIDTH,       320,  WA_MINWIDTH,        320,
                      WA_INNERHEIGHT, 36,  WA_MINHEIGHT,       (topborder + 40),
                      WA_DRAGBAR,    TRUE,  WA_DEPTHGADGET,   TRUE,
                      WA_ACTIVATE,   TRUE,  WA_CLOSEGADGET,   TRUE,
                      WA_SIZEGADGET, FALSE,  WA_SIMPLEREFRESH, TRUE,
                      WA_IDCMP, IDCMP_CLOSEWINDOW OR IDCMP_REFRESHWINDOW OR IDCMP_VANILLAKEY OR BUTTONIDCMP,
                      WA_PUBSCREEN, mysc,
                      NIL]:tagitem)
  -> After window is open, gadgets must be refreshed with a call to the
  -> GadTools refresh window function.
  Gt_RefreshWindow(mywin, NIL)

  process_window_events(mywin)

FINALLY
  IF mywin THEN CloseWindow(mywin)
  -> FreeGadgets() even if createAllGadgets() fails, as some of the gadgets may
  -> have been created...  If glist[0] is NIL then FreeGadgets() will do nothing.
  FreeGadgets(glist[0])
  IF vi THEN FreeVisualInfo(vi)
  IF mysc THEN UnlockPubScreen(NILA, mysc)
  IF font THEN CloseFont(font)
ENDPROC


-> Open all libraries and run.  Clean up when finished or on error..
PROC main()
  KickVersion(37)
  gadtoolsbase:=OpenLibrary('gadtools.library', 37)
  gadtoolsWindow()
FINALLY
  IF gadtoolsbase THEN CloseLibrary(gadtoolsbase)
  SELECT exception
  CASE ERR_FONT; Print('Error: Failed to open Topaz 80\n')
  CASE ERR_GAD;  Print('Error: createAllGadgets() failed\n')
  CASE ERR_KICK; Print('Error: Requires V37\n')
  CASE ERR_LIB;  Print('Error: Requires V37 gadtools.library\n')
  CASE ERR_PUB;  Print('Error: Couldn\'t lock default public screen\n')
  CASE ERR_VIS;  Print('Error: GetVisualInfoA() failed\n')
  CASE ERR_WIN;  Print('Error: OpenWindow() failed\n')
  ENDSELECT
ENDPROC

# adt on Limbon abstrakti datatyyppi, mikä vastaa
# vähän niinkuin hienompaa structia tai köyhänmiehen luokkaa
# joissakin muissa kielissä.
Pino : adt
{
	koko : int;
	pino : array of real;
	uusi : fn() : ref Pino;
	push : fn(pino : self ref Pino, value : real);
	pop : fn(pino :self ref Pino) : (real, string);
};


Pino.uusi() : ref Pino
{
	p := ref Pino (0, nil);

	return p;
}


Pino.push(p : self ref Pino, value : real)
{
	i := p.koko;

	uusipino := array[i + 1] of real;

	(uusipino[0:], uusipino[i], uusipino[i+1:])  =  (p.pino[0:i], value, p.pino[i:]);

	p.pino = uusipino;
	p.koko++;
}


Pino.pop(p : self ref Pino) : (real, string)
{
	if(len p.pino >  0) 	{
		value := p.pino[p.koko - 1];
		p.pino = p.pino[0: p.koko - 1];

		p.koko--;
		return (value, "");
	}
	else
		return (0.0, "Pino on tyhjä");
}

# Reverse Polish Notation laskin
RPNlaskin(lauseke : string) : (real, string)
{

	pino := Pino.uusi();

  	(words, tokens) := sys->tokenize(lauseke, " ");

	if(words == 0)
		return (0.0, "no tokens for RPNcalculator");

	token : string;
	token1 : real;
	token2 : real;
	err : string;

	while(tokens != nil)	{

		token = hd tokens;

		case token 	{
			"+" =>
				if(pino.koko  > 1)	 {
					(token1, err)  = pino.pop();
					(token2, err)  = pino.pop();
					token2 += token1;
					pino.push(token2);
				}
				else
					return (0.0, "Calculator stack empty");

			"-" =>
				if(pino.koko  > 1)	 {
					(token1, err)  = pino.pop();
					(token2, err)  = pino.pop();
					token2 -= token1;
					pino.push(token2);
				}
				else
					return (0.0, "Calculator stack empty");

			"*" =>
				if(pino.koko  > 1)	 {
					(token1, err)  = pino.pop();
					(token2, err)  = pino.pop();
					token2 *= token1;
					pino.push(token2);
				}
				else
					return (0.0, "Calculator stack empty");

			"/" =>
				if(pino.koko  > 1)	 {
					(token1, err)  = pino.pop();
					(token2, err)  = pino.pop();
					if(token1 != 0.0) {
						token2 /= token1;
					}
					else
						return (0.0, "Divide by zero");

					pino.push(token2);
				}
				else
					return (0.0, "Calculator stack empty");

			* =>
				if(isreal(token)) 	{
					pino.push(real token);
				}
				else
					return (0.0, "Calculator syntax error");

		}

		tokens = tl tokens;

	}

	if(pino.koko  != 1)
		return (0.0, "Calculator stack not empty");

	else 	{
		(token1, err) = pino.pop();

		return (token1, "");
	}

}


isreal(input : string) : int
{
	parse := 1;
	count := len input;
	dots := 0;

	if(count == 0)
		return 0;


	i := 0;

	if(input[i] == '-')
		i++;

	for(i = i; i < count; i++) {
		if(input[i] < '0' || input[i] > '9') {
			parse = 0;

			if(input[i] == '.') {
				dots ++;
				parse = 1;

			}
			if(dots > 1 || parse == 0)
				return 0;
		}

	}

	return parse;
}