------------------------------------------------------------------------------
-- BUSH Pen Package Parser                                                  --
--                                                                          --
-- Part of BUSH                                                             --
------------------------------------------------------------------------------
--                                                                          --
--              Copyright (C) 2001-2005 Ken O. Burtch & FSF                 --
--                                                                          --
-- This is free software;  you can  redistribute it  and/or modify it under --
-- terms of the  GNU General Public License as published  by the Free Soft- --
-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
-- sion.  This is distributed in the hope that it will be useful, but WITH- --
-- OUT 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  distributed with this;  see file COPYING.  If not, write --
-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
-- MA 02111-1307, USA.                                                      --
--                                                                          --
-- This is maintained at http://www.pegasoft.ca                             --
--                                                                          --
------------------------------------------------------------------------------
-- CVS: $Id: parser_pen.adb,v 1.1 2005/08/31 15:12:27 ken Exp $

with text_io;use text_io;
with pen,
    bush_os.sdl,
    world,
    scanner,
    string_util,
    parser_aux,
    parser;
use pen,
    bush_os,
    bush_os.sdl,
    world, 
    scanner,
    string_util,
    parser_aux,
    parser,
    bush_os;

package body parser_pen is

penRunning : boolean := false;
-- some versions of SDL take control of the screen if video is started so
-- we'll only start SDL when a canvas is created.

----> Utils

procedure bushRect2penRect( pen_rect : out aRect; bush_rect : identifier ) is
  left_field_t, top_field_t, right_field_t, bottom_field_t : identifier;
begin
  findField( bush_rect, 1, left_field_t );
     pen_rect.left := aCoordinate'Value( to_string( identifiers( left_field_t ).value ) );
  findField( bush_rect, 2, top_field_t );
     pen_rect.top := aCoordinate'Value( to_string( identifiers( top_field_t ).value ) );
  findField( bush_rect, 3, right_field_t );
     pen_rect.right := aCoordinate'Value( to_string( identifiers( right_field_t ).value ) );
  findField( bush_rect, 4, bottom_field_t );
     pen_rect.bottom := aCoordinate'Value( to_string( identifiers( bottom_field_t ).value ) );
end bushRect2penRect;

procedure penRect2bushRect( pen_rect : aRect; bush_rect : identifier ) is
  left_field_t, top_field_t, right_field_t, bottom_field_t : identifier;
begin
  findField( bush_rect, 1, left_field_t );
     identifiers( left_field_t ).value := to_unbounded_string( long_float( pen_rect.left ) );
  findField( bush_rect, 2, top_field_t );
     identifiers( top_field_t ).value := to_unbounded_string( long_float( pen_rect.top ) );
  findField( bush_rect, 3, right_field_t );
     identifiers( right_field_t ).value := to_unbounded_string( long_float( pen_rect.right ) );
  findField( bush_rect, 4, bottom_field_t );
     identifiers( bottom_field_t ).value := to_unbounded_string( long_float( pen_rect.bottom ) );
end penRect2bushRect;


----> Rects

procedure ParsePenSetRect is
  -- Syntax: pen.set_rect( rec, left, top, right, bottom );
  -- Source: Pen.setRect
  record_ref : reference;
  record_type : identifier := pen_rect_t;
  -- record_id : identifier;
  left_val,  top_val,  right_val,  bottom_val  : unbounded_string;
  left_type, top_type, right_type, bottom_type : identifier;
begin
  expect( pen_set_rect_t );
  expect( symbol_t, "(" );
  -- ParseIdentifier( record_id );
  ParseOutParameter( record_ref, record_type );
  if baseTypesOk( record_type, pen_rect_t ) then
  -- if baseTypesOk( identifiers( record_id ).kind, pen_rect_t ) then
     expect( symbol_t, "," );
     ParseExpression( left_val, left_type );
     if baseTypesOk( left_type, pen_coordinate_t ) then
        expect( symbol_t, "," );
        ParseExpression( top_val, top_type );
        if baseTypesOk( top_type, pen_coordinate_t ) then
           expect( symbol_t, "," );
           ParseExpression( right_val, right_type );
           if baseTypesOk( right_type, pen_coordinate_t ) then
              expect( symbol_t, "," );
              ParseExpression( bottom_val, bottom_type );
              if baseTypesOk( bottom_type, pen_coordinate_t ) then
                 expect( symbol_t, ")" );
              end if;
           end if;
        end if;
     end if;
  end if;
  if isExecutingCommand then
     declare
       left_field_t, top_field_t, right_field_t, bottom_field_t : identifier;
     begin
       findField( record_ref.id, 1, left_field_t );
          identifiers( left_field_t ).value := left_val;
       findField( record_ref.id, 2, top_field_t );
          identifiers( top_field_t ).value := top_val;
       findField( record_ref.id, 3, right_field_t );
          identifiers( right_field_t ).value := right_val;
       findField( record_ref.id, 4, bottom_field_t );
          identifiers( bottom_field_t ).value := bottom_val;
     exception when others =>
        err( "exception raised" );
     end;
  end if;
end ParsePenSetRect;

procedure ParsePenIsEmptyRect( result : out unbounded_string ) is
  -- Syntax: b := pen.is_empty_rect( rec );
  -- Source: Pen.isEmptyRect
  record_id : identifier;
begin
  expect( pen_is_empty_rect_t );
  expect( symbol_t, "(" );
  ParseIdentifier( record_id );
  if baseTypesOk( identifiers( record_id ).kind, pen_rect_t ) then
     expect( symbol_t, ")" );
  end if;
  if isExecutingCommand then
     declare
       pen_rect : aRect;
     begin
       bushRect2penRect( pen_rect, record_id );
       result := to_bush_boolean( isEmptyRect( pen_rect ) );
     exception when others =>
        err( "exception raised" );
     end;
  end if;
end ParsePenIsEmptyRect;

procedure ParsePenOffsetRect is
  -- Syntax: pen.offset_rect( rect, dx, dy );
  -- Source: Pen.offsetRect
  record_id : identifier;
  dx_val, dy_val : unbounded_string;
  dx_type, dy_type : identifier;
begin
  expect( pen_offset_rect_t );
  expect( symbol_t, "(" );
  ParseIdentifier( record_id );
  if baseTypesOk( identifiers( record_id ).kind, pen_rect_t ) then
     expect( symbol_t, "," );
     ParseExpression( dx_val, dx_type );
     if baseTypesOk( dx_type, pen_coordinate_t ) then
        expect( symbol_t, "," );
        ParseExpression( dy_val, dy_type );
        if baseTypesOk( dy_type, pen_coordinate_t ) then
           expect( symbol_t, ")" );
        end if;
     end if;
  end if;
  if isExecutingCommand then
     declare
       pen_rect : aRect;
     begin
       bushRect2penRect( pen_rect, record_id );
       offsetRect( pen_rect, aCoordinate( to_numeric( dx_val ) ),aCoordinate( to_numeric( dy_val ) ) );
       penRect2bushRect( pen_rect, record_id );
     exception when others =>
        err( "exception raised" );
     end;
  end if;
end ParsePenOffsetRect;

procedure ParsePenInsetRect is
  -- Syntax: pen.inset_rect( rect, dx, dy );
  -- Source: Pen.insetRect
  record_id : identifier;
  dx_val, dy_val : unbounded_string;
  dx_type, dy_type : identifier;
begin
  expect( pen_inset_rect_t );
  expect( symbol_t, "(" );
  ParseIdentifier( record_id );
  if baseTypesOk( identifiers( record_id ).kind, pen_rect_t ) then
     expect( symbol_t, "," );
     ParseExpression( dx_val, dx_type );
     if baseTypesOk( dx_type, pen_coordinate_t ) then
        expect( symbol_t, "," );
        ParseExpression( dy_val, dy_type );
        if baseTypesOk( dy_type, pen_coordinate_t ) then
           expect( symbol_t, ")" );
        end if;
     end if;
  end if;
  if isExecutingCommand then
     declare
       pen_rect : aRect;
     begin
       bushRect2penRect( pen_rect, record_id );
       insetRect( pen_rect, aCoordinate( to_numeric( dx_val ) ),aCoordinate( to_numeric( dy_val ) ) );
       penRect2bushRect( pen_rect, record_id );
     exception when others =>
        err( "exception raised" );
     end;
  end if;
end ParsePenInsetRect;

procedure ParsePenIntersectRect is
  -- Syntax: pen.intersect_rect( rect, r1, r2 );
  -- Note: BUSH 1.0.2 cannot return record values so must use procedural version
  -- Source: Pen.intersectRect
  record_id : identifier;
  record1_id : identifier;
  record2_id : identifier;
begin
  expect( pen_intersect_rect_t );
  expect( symbol_t, "(" );
  ParseIdentifier( record_id );
  if baseTypesOk( identifiers( record_id ).kind, pen_rect_t ) then
     expect( symbol_t, "," );
     ParseIdentifier( record1_id );
     if baseTypesOk( identifiers( record1_id ).kind, pen_rect_t ) then
        expect( symbol_t, "," );
        ParseIdentifier( record2_id );
        if baseTypesOk( identifiers( record2_id ).kind, pen_rect_t ) then
           expect( symbol_t, ")" );
        end if;
     end if;
  end if;
  if isExecutingCommand then
     declare
       pen_rect : aRect;
       pen_rect1 : aRect;
       pen_rect2 : aRect;
     begin
       bushRect2penRect( pen_rect1, record1_id );
       bushRect2penRect( pen_rect2, record2_id );
       intersectRect( pen_rect, pen_rect1, pen_rect2 );
       penRect2bushRect( pen_rect, record_id );
     exception when others =>
        err( "exception raised" );
     end;
  end if;
end ParsePenIntersectRect;

procedure ParsePenInsideRect( result : out unbounded_string ) is
  -- Syntax: b := pen.inside_rect( rect, rect2 );
  -- Source: Pen.insideRect
  record_id : identifier;
  record2_id : identifier;
  --x_val, y_val : unbounded_string;
  --x_type, y_type : identifier;
begin
  expect( pen_inside_rect_t );
  expect( symbol_t, "(" );
  ParseIdentifier( record_id );
  if baseTypesOk( identifiers( record_id ).kind, pen_rect_t ) then
     expect( symbol_t, "," );
     ParseIdentifier( record2_id );
     if baseTypesOk( identifiers( record_id ).kind, pen_rect_t ) then
        expect( symbol_t, ")" );
     end if;
  end if;
  if isExecutingCommand then
     declare
       pen_rect : aRect;
       pen_rect2 : aRect;
     begin
       bushRect2penRect( pen_rect, record_id );
       bushRect2penRect( pen_rect2, record2_id );
       result := to_bush_boolean( insideRect( pen_rect, pen_rect2 ) );
     exception when others =>
        err( "exception raised" );
     end;
  end if;
end ParsePenInsideRect;

procedure ParsePenInRect( result : out unbounded_string ) is
  -- Syntax: b := pen.in_rect( rect, x, y );
  -- Source: Pen.inRect
  record_id : identifier;
  x_val, y_val : unbounded_string;
  x_type, y_type : identifier;
begin
  expect( pen_in_rect_t );
  expect( symbol_t, "(" );
     ParseExpression( x_val, x_type );
     if baseTypesOk( x_type, pen_coordinate_t ) then
        expect( symbol_t, "," );
        ParseExpression( y_val, y_type );
        if baseTypesOk( y_type, pen_coordinate_t ) then
           expect( symbol_t, "," );
           ParseIdentifier( record_id );
           if baseTypesOk( identifiers( record_id ).kind, pen_rect_t ) then
              expect( symbol_t, ")" );
        end if;
     end if;
  end if;
  if isExecutingCommand then
     declare
       pen_rect : aRect;
     begin
       bushRect2penRect( pen_rect, record_id );
       result := to_bush_boolean( inRect( ACoordinate( to_numeric( x_val ) ), ACoordinate( to_numeric( y_val ) ), pen_rect ) );
     exception when others =>
        err( "exception raised" );
     end;
  end if;
end ParsePenInRect;

procedure ParsePenSetPenMode is
  -- Syntax: pen.set_pen_mode( canvas_id, mode );
  -- Source: Pen.setPenMode
  canvas_id : identifier;
  mode_val  : unbounded_string;
  mode_type : identifier;
begin
  expect( pen_set_pen_mode_t );
  expect( symbol_t, "(" );
  ParseIdentifier( canvas_id );
  if baseTypesOk( identifiers( canvas_id ).kind, pen_canvas_id_t ) then
     expect( symbol_t, "," );
     ParseExpression( mode_val, mode_type );
     if baseTypesOk( mode_type, pen_pen_mode_t ) then
        expect( symbol_t, ")" );
     end if;
  end if;

  if isExecutingCommand then
     begin
       setPenMode( aCanvasID( to_numeric( canvas_id ) ), aPenMode'val( natural( to_numeric( mode_val ) ) ) );
     exception when others =>
        err( "exception raised" );
     end;
  end if;
end ParsePenSetPenMode;

procedure ParsePenGetPenMode( result : out unbounded_string ) is
  -- Syntax: mode := pen.get_pen_mode( canvas_id );
  -- Source: Pen.getPenMode
  canvas_id : identifier;
begin
  expect( pen_get_pen_mode_t );
  expect( symbol_t, "(" );
  ParseIdentifier( canvas_id );
  if baseTypesOk( identifiers( canvas_id ).kind, pen_canvas_id_t ) then
     expect( symbol_t, ")" );
  end if;

  if isExecutingCommand then
     begin
       result := to_unbounded_string( aPenMode'pos( getPenMode( aCanvasID( to_numeric( canvas_id ) ) ) )'img );
       delete( result, 1, 1 );
     exception when others =>
        err( "exception raised" );
     end;
  end if;
end ParsePenGetPenMode;

procedure ParsePenSetPenInk is
  -- Syntax: pen.set_pen_ink( canvas_id, r, g, b );
  -- Source: Pen.setPenInk
  canvas_id : identifier;
  R_val,  G_val,  B_val  : unbounded_string;
  R_type, G_type, B_type : identifier;
begin
  expect( pen_set_pen_ink_t );
  expect( symbol_t, "(" );
  ParseIdentifier( canvas_id );
  if baseTypesOk( identifiers( canvas_id ).kind, pen_canvas_id_t ) then
     expect( symbol_t, "," );
     ParseExpression( R_val, R_type );
     if baseTypesOk( R_type, pen_rgbcomponent_t ) then
        expect( symbol_t, "," );
        ParseExpression( G_val, G_type );
        if baseTypesOk( G_type, pen_rgbcomponent_t ) then
           expect( symbol_t, "," );
           ParseExpression( B_val, B_type );
           if baseTypesOk( B_type, pen_rgbcomponent_t ) then
             expect( symbol_t, ")" );
           end if;
        end if;
     end if;
  end if;

  if isExecutingCommand then
     begin
       setPenInk( aCanvasID( to_numeric( canvas_id ) ), aRGBComponent( to_numeric( R_val ) ), aRGBComponent( to_numeric( G_val ) ), aRGBComponent( to_numeric( B_val ) ) );
     exception when others =>
        err( "exception raised" );
     end;
  end if;
end ParsePenSetPenInk;

procedure ParsePenGetPenInk is
  -- Syntax: pen.get_pen_ink( canvas_id, r, g, b );
  -- Source: Pen.getPenInk
  canvas_id : identifier;
  R_id, G_id, B_id : identifier;
begin
  expect( pen_get_pen_ink_t );
  expect( symbol_t, "(" );
  ParseIdentifier( canvas_id );
  if baseTypesOk( identifiers( canvas_id ).kind, pen_canvas_id_t ) then
     expect( symbol_t, "," );
     ParseIdentifier( R_id );
     if baseTypesOk( identifiers( R_id ).kind, pen_rgbcomponent_t ) then
        expect( symbol_t, "," );
        ParseIdentifier( G_id );
        if baseTypesOk( identifiers( G_id ).kind, pen_rgbcomponent_t ) then
           expect( symbol_t, "," );
           ParseIdentifier( B_id );
           if baseTypesOk( identifiers( B_id ).kind, pen_rgbcomponent_t ) then
             expect( symbol_t, ")" );
           end if;
        end if;
     end if;
  end if;

  if isExecutingCommand then
     declare
       R, G, B : aRGBComponent;
     begin
       getPenInk( aCanvasID( to_numeric( canvas_id ) ), R, G, B );
       identifiers( R_id ).value := to_unbounded_string( R'img );
       identifiers( G_id ).value := to_unbounded_string( G'img );
       identifiers( B_id ).value := to_unbounded_string( B'img );
     exception when others =>
        err( "exception raised" );
     end;
  end if;
end ParsePenGetPenInk;

procedure ParsePenSetPenBrush is
  -- Syntax: pen.set_pen_brush( canvas_id );
  -- Source: Pen.setPenBrush
  canvas_id : identifier;
  brush_val : unbounded_string;
  brush_type: identifier;
begin
  expect( pen_set_pen_brush_t );
  expect( symbol_t, "(" );
  ParseIdentifier( canvas_id );
  if baseTypesOk( identifiers( canvas_id ).kind, pen_canvas_id_t ) then
     expect( symbol_t, "," );
     ParseExpression( brush_val, brush_type );
     if baseTypesOk( brush_type, pen_pen_brush_t ) then
        expect( symbol_t, ")" );
     end if;
  end if;

  if isExecutingCommand then
     begin
       setPenBrush( aCanvasID( to_numeric( canvas_id ) ), aPenBrush'val( natural( to_numeric( brush_val ) ) ) );
     exception when others =>
        err( "exception raised" );
     end;
  end if;
end ParsePenSetPenBrush;

procedure ParsePenGetPenBrush( result : out unbounded_string ) is
  -- Syntax: brush := pen.get_pen_brush( canvas_id );
  -- Source: Pen.getPenBrush
  canvas_id : identifier;
begin
  expect( pen_get_pen_brush_t );
  expect( symbol_t, "(" );
  ParseIdentifier( canvas_id );
  if baseTypesOk( identifiers( canvas_id ).kind, pen_canvas_id_t ) then
     expect( symbol_t, ")" );
  end if;

  if isExecutingCommand then
     begin
       result := to_unbounded_string( aPenBrush'pos( getPenBrush( aCanvasID( to_numeric( canvas_id ) ) ) )'img );
       delete( result, 1, 1 );
     exception when others =>
        err( "exception raised" );
     end;
  end if;
end ParsePenGetPenBrush;

procedure ParsePenSetPenPattern is
  -- Syntax: pen.set_pen_pattern( canvas_id, brush_canvas_id );
  -- Source: Pen.setPenPattern
  canvas_id : identifier;
  brush_id  : identifier;
begin
  expect( pen_set_pen_pattern_t );
  expect( symbol_t, "(" );
  ParseIdentifier( canvas_id );
  if baseTypesOk( identifiers( canvas_id ).kind, pen_canvas_id_t ) then
     expect( symbol_t, "," );
     ParseIdentifier( brush_id );
     if baseTypesOk( identifiers( brush_id ).kind, pen_canvas_id_t ) then
        expect( symbol_t, ")" );
     end if;
  end if;

  if isExecutingCommand then
     begin
       setPenPattern( aCanvasID( to_numeric( canvas_id ) ), aCanvasID( to_numeric( brush_id ) ) );
     exception when others =>
        err( "exception raised" );
     end;
  end if;
end ParsePenSetPenPattern;

--procedure ParsePenGetPenPattern( result : out unbounded_string ) is
--  -- Syntax: pattern_canvas_id := pen.get_pen_pattern( canvas_id );
--  -- Source: Pen.getPenMode
--  canvas_id : identifier;
--begin
--  expect( pen_get_pen_pattern_t );
--  expect( symbol_t, "(" );
--  ParseIdentifier( canvas_id );
--  if baseTypesOk( identifiers( canvas_id ).kind, pen_canvas_id_t ) then
--     expect( symbol_t, ")" );
--  end if;
--
--  if isExecutingCommand then
--     begin
--       result := to_unbounded_string( aCanvasID'image( getPenPattern( aCanvasID( to_numeric( canvas_id ) ) ) ) );
--       delete( result, 1, 1 );
--     exception when others =>
--        err( "exception raised" );
--     end;
--  end if;
--end ParsePenGetPenPattern;

procedure ParsePenNewScreenCanvas is
  -- Syntax: pen.new_screen_canvas( H_Res, V_Res, C_Res, canvas_id );
  -- Source: Pen.newScreenCanvas
  h_val,  v_val,  c_val : unbounded_string;
  h_type, v_type, c_type : identifier;
  canvas_ref : reference;
  canvas_type : identifier := pen_canvas_id_t;
  C_Res : positive;
begin
  expect( pen_new_screen_canvas_t );
  --if inputMode = interactive or inputMode = breakout then
  --   err( "screen canvas is not allowed in an interactive session" );
  --end if;
  -- But what about when it is only option? ie. non-X session
  expect( symbol_t, "(" );
  ParseExpression( h_val, h_type );
  if baseTypesOk( h_type, positive_t ) then
     expect( symbol_t, "," );
     ParseExpression( v_val, v_type );
     if baseTypesOk( v_type, positive_t ) then
        expect( symbol_t, "," );
        ParseExpression( c_val, c_type );
        if baseTypesOk( c_type, positive_t ) then
           C_Res := positive( to_numeric( C_val ) );
           if C_Res /= 8 and C_Res /= 16 and C_Res /= 24 and C_Res /= 32 then
              err( "pixel bit resolution must be 8, 16, 24 or 32" );
           end if;
           expect( symbol_t, "," );
           ParseOutParameter( canvas_ref, canvas_type );
           if baseTypesOk( canvas_type, pen_canvas_id_t ) then
              expect( symbol_t, ")" );
           end if;
        end if;
     end if;
  end if;
  if isExecutingCommand then
     declare
        id : aCanvasID;
     begin
-- some versions of SDL take control of the screen if video is started so
-- we'll only start SDL when a canvas is created.
        if not penRunning then
           pen.startupPen;
           penRunning := true;
        end if;
        newScreenCanvas( positive( to_numeric( h_val ) ),
                         positive( to_numeric( v_val ) ),
                         C_Res, id );
        identifiers( canvas_ref.id ).value := to_unbounded_string( long_float( id ) );
     exception when others =>
        err( "exception raised" );
     end;
  end if;
end ParsePenNewScreenCanvas;

procedure ParsePenNewWindowCanvas is
  -- Syntax: pen.new_window_canvas( H_Res, V_Res, C_Res, canvas_id );
  -- Source: Pen.newWindowCanvas
  h_val,  v_val,  c_val : unbounded_string;
  h_type, v_type, c_type : identifier;
  canvas_ref : reference;
  canvas_type : identifier := pen_canvas_id_t;
  C_Res : positive;
begin
  expect( pen_new_window_canvas_t );
  expect( symbol_t, "(" );
  ParseExpression( h_val, h_type );
  if baseTypesOk( h_type, positive_t ) then
     expect( symbol_t, "," );
     ParseExpression( v_val, v_type );
     if baseTypesOk( v_type, positive_t ) then
        expect( symbol_t, "," );
        ParseExpression( c_val, c_type );
        if baseTypesOk( c_type, positive_t ) then
           C_Res := positive( to_numeric( C_val ) );
           if C_Res /= 8 and C_Res /= 16 and C_Res /= 24 and C_Res /= 32 then
              err( "pixel bit resolution must be 8, 16, 24 or 32" );
           end if;
           expect( symbol_t, "," );
           ParseOutParameter( canvas_ref, canvas_type );
           if baseTypesOk( canvas_type, pen_canvas_id_t ) then
              expect( symbol_t, ")" );
           end if;
        end if;
     end if;
  end if;
  if isExecutingCommand then
     declare
        id : aCanvasID;
     begin
-- some versions of SDL take control of the screen if video is started so
-- we'll only start SDL when a canvas is created.
        if not penRunning then
           pen.startupPen;
           penRunning := true;
        end if;
        newWindowCanvas( positive( to_numeric( h_val ) ),
                         positive( to_numeric( v_val ) ),
                         C_Res, id );
        identifiers( canvas_ref.id ).value := to_unbounded_string( long_float( id ) );
     exception when others =>
        err( "exception raised" );
     end;
  end if;
end ParsePenNewWindowCanvas;

procedure ParsePenNewCanvas is
  -- Syntax: pen.new_canvas( H_Res, V_Res, C_Res, canvas_id );
  --         pen.new_canvas( path, canvas_id );
  -- Source: Pen.newCanvas
  h_val,  v_val,  c_val : unbounded_string;
  h_type, v_type, c_type : identifier;
  canvas_ref : reference;
  canvas_type : identifier := pen_canvas_id_t;
  C_Res : positive;
  loading : boolean := false;
begin
  expect( pen_new_canvas_t );
  expect( symbol_t, "(" );
  ParseExpression( h_val, h_type );
  if getBaseType( h_type ) = positive_t then
     expect( symbol_t, "," );
     ParseExpression( v_val, v_type );
     if baseTypesOk( v_type, positive_t ) then
        expect( symbol_t, "," );
        ParseExpression( c_val, c_type );
        if baseTypesOk( c_type, positive_t ) then
           C_Res := positive( to_numeric( C_val ) );
           if C_Res /= 8 and C_Res /= 16 and C_Res /= 24 and C_Res /= 32 then
              err( "pixel bit resolution must be 8, 16, 24 or 32" );
           end if;
           expect( symbol_t, "," );
           ParseOutParameter( canvas_ref, canvas_type );
           if baseTypesOk( canvas_type, pen_canvas_id_t ) then
              expect( symbol_t, ")" );
           end if;
        end if;
     end if;
  elsif getBaseType( h_type ) = uni_string_t then
     loading := true;
     expect( symbol_t, "," );
     ParseOutParameter( canvas_ref, canvas_type );
     if baseTypesOk( canvas_type, pen_canvas_id_t ) then
        expect( symbol_t, ")" );
     end if;
  else
     err( "positive or string expected" );
  end if;
  if isExecutingCommand then
     declare
        id : aCanvasID;
     begin
-- some versions of SDL take control of the screen if video is started so
-- we'll only start SDL when a canvas is created.
        if not penRunning then
           pen.startupPen;
           penRunning := true;
        end if;
        if loading then
           newCanvas( to_string( h_val ), id );
        else
           newCanvas( positive( to_numeric( h_val ) ),
                         positive( to_numeric( v_val ) ),
                         C_Res, id );
        end if;
        identifiers( canvas_ref.id ).value := to_unbounded_string( long_float( id ) );
     exception when others =>
        err( "exception raised" );
     end;
  end if;
end ParsePenNewCanvas;

procedure ParsePenMoveTo is
  -- Syntax: pen.move_to( canvas_id, dx, dy );
  -- Source: Pen.MoveTo
  canvas_id : identifier;
  x_val, y_val : unbounded_string;
  x_type, y_type : identifier;
begin
  expect( pen_move_to_t );
  expect( symbol_t, "(" );
  ParseIdentifier( canvas_id );
  if baseTypesOk( identifiers( canvas_id ).kind, pen_canvas_id_t ) then
     expect( symbol_t, "," );
     ParseExpression( x_val, x_type );
     if baseTypesOk( x_type, pen_coordinate_t ) then
        expect( symbol_t, "," );
        ParseExpression( y_val, y_type );
        if baseTypesOk( y_type, pen_coordinate_t ) then
           expect( symbol_t, ")" );
        end if;
     end if;
  end if;

  if isExecutingCommand then
     begin
       moveTo( aCanvasID( to_numeric( canvas_id ) ),
             aCoordinate( to_numeric( x_val ) ),
             aCoordinate( to_numeric( y_val ) ) );
     exception when others =>
        err( "exception raised" );
     end;
  end if;
end ParsePenMoveTo;

procedure ParsePenMove is
  -- Syntax: pen.move( canvas_id, dx, dy );
  -- Source: Pen.Move
  canvas_id : identifier;
  dx_val, dy_val : unbounded_string;
  dx_type, dy_type : identifier;
begin
  expect( pen_move_t );
  expect( symbol_t, "(" );
  ParseIdentifier( canvas_id );
  if baseTypesOk( identifiers( canvas_id ).kind, pen_canvas_id_t ) then
     expect( symbol_t, "," );
     ParseExpression( dx_val, dx_type );
     if baseTypesOk( dx_type, pen_coordinate_t ) then
        expect( symbol_t, "," );
        ParseExpression( dy_val, dy_type );
        if baseTypesOk( dy_type, pen_coordinate_t ) then
           expect( symbol_t, ")" );
        end if;
     end if;
  end if;

  if isExecutingCommand then
     begin
       move( aCanvasID( to_numeric( canvas_id ) ),
             aCoordinate( to_numeric( dx_val ) ),
             aCoordinate( to_numeric( dy_val ) ) );
     exception when others =>
        err( "exception raised" );
     end;
  end if;
end ParsePenMove;

procedure ParsePenLineTo is
  -- Syntax: pen.line_to( canvas_id, dx, dy );
  -- Source: Pen.LineTo
  canvas_id : identifier;
  x_val, y_val : unbounded_string;
  x_type, y_type : identifier;
begin
  expect( pen_line_to_t );
  expect( symbol_t, "(" );
  ParseIdentifier( canvas_id );
  if baseTypesOk( identifiers( canvas_id ).kind, pen_canvas_id_t ) then
     expect( symbol_t, "," );
     ParseExpression( x_val, x_type );
     if baseTypesOk( x_type, pen_coordinate_t ) then
        expect( symbol_t, "," );
        ParseExpression( y_val, y_type );
        if baseTypesOk( y_type, pen_coordinate_t ) then
           expect( symbol_t, ")" );
        end if;
     end if;
  end if;

  if isExecutingCommand then
     begin
       lineTo( aCanvasID( to_numeric( canvas_id ) ),
             aCoordinate( to_numeric( x_val ) ),
             aCoordinate( to_numeric( y_val ) ) );
     exception when others =>
        err( "exception raised" );
     end;
  end if;
end ParsePenLineTo;

procedure ParsePenLine is
  -- Syntax: pen.line( canvas_id, dx, dy );
  -- Source: Pen.Line
  canvas_id : identifier;
  dx_val, dy_val : unbounded_string;
  dx_type, dy_type : identifier;
begin
  expect( pen_line_t );
  expect( symbol_t, "(" );
  ParseIdentifier( canvas_id );
  if baseTypesOk( identifiers( canvas_id ).kind, pen_canvas_id_t ) then
     expect( symbol_t, "," );
     ParseExpression( dx_val, dx_type );
     if baseTypesOk( dx_type, pen_coordinate_t ) then
        expect( symbol_t, "," );
        ParseExpression( dy_val, dy_type );
        if baseTypesOk( dy_type, pen_coordinate_t ) then
           expect( symbol_t, ")" );
        end if;
     end if;
  end if;

  if isExecutingCommand then
     begin
       line( aCanvasID( to_numeric( canvas_id ) ),
             aCoordinate( to_numeric( dx_val ) ),
             aCoordinate( to_numeric( dy_val ) ) );
     exception when others =>
        err( "exception raised" );
     end;
  end if;
end ParsePenLine;

procedure ParsePenFrameRect is
  -- Syntax: pen.frame_rect( canvas_id, r );
  -- Source: Pen.FrameRect
  canvas_id : identifier;
  rect_id   : identifier;
begin
  expect( pen_frame_rect_t );
  expect( symbol_t, "(" );
  ParseIdentifier( canvas_id );
  if baseTypesOk( identifiers( canvas_id ).kind, pen_canvas_id_t ) then
     expect( symbol_t, "," );
     ParseIdentifier( rect_id );
     if baseTypesOk( identifiers( rect_id ).kind, pen_rect_t ) then
        expect( symbol_t, ")" );
     end if;
  end if;

  if isExecutingCommand then
     declare
       pen_rect : aRect;
     begin
       bushRect2penRect( pen_rect, rect_id );
       frameRect( aCanvasID( to_numeric( canvas_id ) ), pen_rect );
     exception when others =>
        err( "exception raised" );
     end;
  end if;
end ParsePenFrameRect;

procedure ParsePenFillRect is
  -- Syntax: pen.fill_rect( canvas_id, r );
  -- Source: Pen.FillRect
  canvas_id : identifier;
  rect_id   : identifier;
begin
  expect( pen_fill_rect_t );
  expect( symbol_t, "(" );
  ParseIdentifier( canvas_id );
  if baseTypesOk( identifiers( canvas_id ).kind, pen_canvas_id_t ) then
     expect( symbol_t, "," );
     ParseIdentifier( rect_id );
     if baseTypesOk( identifiers( rect_id ).kind, pen_rect_t ) then
        expect( symbol_t, ")" );
     end if;
  end if;

  if isExecutingCommand then
     declare
       pen_rect : aRect;
     begin
       bushRect2penRect( pen_rect, rect_id );
       fillRect( aCanvasID( to_numeric( canvas_id ) ), pen_rect );
     exception when others =>
        err( "exception raised" );
     end;
  end if;
end ParsePenFillRect;

procedure ParsePenFrameEllipse is
  -- Syntax: pen.frame_ellipse( canvas_id, r );
  -- Source: Pen.FrameEllipse
  canvas_id : identifier;
  rect_id   : identifier;
begin
  expect( pen_frame_ellipse_t );
  expect( symbol_t, "(" );
  ParseIdentifier( canvas_id );
  if baseTypesOk( identifiers( canvas_id ).kind, pen_canvas_id_t ) then
     expect( symbol_t, "," );
     ParseIdentifier( rect_id );
     if baseTypesOk( identifiers( rect_id ).kind, pen_rect_t ) then
        expect( symbol_t, ")" );
     end if;
  end if;

  if isExecutingCommand then
     declare
       pen_rect : aRect;
     begin
       bushRect2penRect( pen_rect, rect_id );
       frameEllipse( aCanvasID( to_numeric( canvas_id ) ), pen_rect );
     exception when others =>
        err( "exception raised" );
     end;
  end if;
end ParsePenFrameEllipse;

procedure ParsePenFillEllipse is
  -- Syntax: pen.fill_ellipse( canvas_id, r );
  -- Source: Pen.FillEllipse
  canvas_id : identifier;
  rect_id   : identifier;
begin
  expect( pen_fill_ellipse_t );
  expect( symbol_t, "(" );
  ParseIdentifier( canvas_id );
  if baseTypesOk( identifiers( canvas_id ).kind, pen_canvas_id_t ) then
     expect( symbol_t, "," );
     ParseIdentifier( rect_id );
     if baseTypesOk( identifiers( rect_id ).kind, pen_rect_t ) then
        expect( symbol_t, ")" );
     end if;
  end if;

  if isExecutingCommand then
     declare
       pen_rect : aRect;
     begin
       bushRect2penRect( pen_rect, rect_id );
       fillEllipse( aCanvasID( to_numeric( canvas_id ) ), pen_rect );
     exception when others =>
        err( "exception raised" );
     end;
  end if;
end ParsePenFillEllipse;

procedure ParsePenSetTitle is
  -- Syntax: pen.set_title( canvas_id, "title" );
  -- Source: Pen.SetTitle
  canvas_id : identifier;
  expr_val  : unbounded_string;
  expr_type : identifier;
begin
  expect( pen_set_title_t );
  expect( symbol_t, "(" );
  ParseIdentifier( canvas_id );
  if baseTypesOk( identifiers( canvas_id ).kind, pen_canvas_id_t ) then
     expect( symbol_t, "," );
     ParseExpression( expr_val, expr_type );
     if baseTypesOk( expr_type, uni_string_t ) then
        expect( symbol_t, ")" );
     end if;
  end if;

  if isExecutingCommand then
     begin
       setTitle( aCanvasID( to_numeric( canvas_id ) ), expr_val );
     exception when others =>
        err( "exception raised" );
     end;
  end if;
end ParsePenSetTitle;

procedure StartupPen is
begin

  declareIdent( pen_coordinate_t, "pen.coordinate", float_t, typeClass );

  declareIdent( pen_rgbcomponent_t, "pen.rgbcomponent", float_t, typeClass );

  declareIdent( pen_rect_t, "pen.rect", root_record_t, typeClass );

  identifiers( pen_rect_t ).value := to_unbounded_string( "4" );
  declareIdent( pen_rect_left_t, "pen.rect.left", pen_coordinate_t, subClass );
  identifiers( pen_rect_left_t ).field_of := pen_rect_t;
  identifiers( pen_rect_left_t ).value := to_unbounded_string( "1" );
  declareIdent( pen_rect_top_t, "pen.a_rect.top", pen_coordinate_t, subClass );
  identifiers( pen_rect_top_t ).field_of := pen_rect_t;
  identifiers( pen_rect_top_t ).value := to_unbounded_string( "2" );
  declareIdent( pen_rect_right_t, "pen.rect.right", pen_coordinate_t, subClass );
  identifiers( pen_rect_right_t ).field_of := pen_rect_t;
  identifiers( pen_rect_right_t ).value := to_unbounded_string( "3" );
  declareIdent( pen_rect_bottom_t, "pen.rect.bottom", pen_coordinate_t, subClass );
  identifiers( pen_rect_bottom_t ).field_of := pen_rect_t;
  identifiers( pen_rect_bottom_t ).value := to_unbounded_string( "4" );

  declareIdent( pen_canvas_id_t, "pen.canvas_id", long_integer_t, typeClass );

  declareIdent( pen_pen_mode_t, "pen.pen_mode", root_enumerated_t, typeClass );
  declareStandardConstant( pen_mode_invert_t, "pen_mode.invert", pen_pen_mode_t, "0" );
  declareStandardConstant( pen_mode_add_t, "pen_mode.add", pen_pen_mode_t, "1" );
  declareStandardConstant( pen_mode_subtract_t, "pen_mode.subtract", pen_pen_mode_t, "2" );
  declareStandardConstant( pen_mode_average_t, "pen_mode.average", pen_pen_mode_t, "3" );
  declareStandardConstant( pen_mode_copy_t, "pen_mode.copy", pen_pen_mode_t, "4" );
  declareStandardConstant( pen_mode_off_t, "pen_mode.off", pen_pen_mode_t, "5" );

  declareIdent( pen_pen_brush_t, "pen.pen_brush", root_enumerated_t, typeClass );
  declareStandardConstant( pen_brush_undefined_t, "pen_brush.undefined", pen_pen_brush_t, "0" );
  declareStandardConstant( pen_brush_pencil_t, "pen_brush.pencil", pen_pen_brush_t, "1" );
  declareStandardConstant( pen_brush_stretch_t, "pen_brush.stretch", pen_pen_brush_t, "2" );
  declareStandardConstant( pen_brush_tile_t, "pen_brush.tile", pen_pen_brush_t, "3" );
  declareStandardConstant( pen_brush_stamp_t, "pen_brush.stamp", pen_pen_brush_t, "4" );
  declareStandardConstant( pen_brush_smear_t, "pen_brush.smear", pen_pen_brush_t, "5" );

-- null rect needs to be declared

  declareProcedure( pen_set_rect_t, "pen.set_rect" );
  declareFunction( pen_is_empty_rect_t, "pen.is_empty_rect" );
  declareProcedure( pen_offset_rect_t, "pen.offset_rect" );
  declareProcedure( pen_inset_rect_t, "pen.inset_rect" );
  declareProcedure( pen_intersect_rect_t, "pen.intersect_rect" );
  declareProcedure( pen_inside_rect_t, "pen.inside_rect" );
  declareProcedure( pen_in_rect_t, "pen.in_rect" );

  declareProcedure( pen_set_pen_mode_t, "pen.set_pen_mode" );
  declareProcedure( pen_set_pen_ink_t, "pen.set_pen_ink" );
  declareProcedure( pen_set_pen_brush_t, "pen.set_pen_brush" );
  declareProcedure( pen_set_pen_pattern_t, "pen.set_pen_pattern" );
  declareFunction( pen_get_pen_mode_t, "pen.get_pen_mode" );
  declareProcedure( pen_get_pen_ink_t, "pen.get_pen_ink" );
  declareFunction( pen_get_pen_brush_t, "pen.get_pen_brush" );
--  declareFunction( pen_get_pen_pattern_t, "pen.get_pen_pattern" );

  declareProcedure( pen_move_to_t, "pen.move_to" );
  declareProcedure( pen_move_t, "pen.move" );
  declareProcedure( pen_line_to_t, "pen.line_to" );
  declareProcedure( pen_line_t, "pen.line" );

  declareProcedure( pen_frame_rect_t, "pen.frame_rect" );
  declareProcedure( pen_fill_rect_t, "pen.fill_rect" );
  declareProcedure( pen_frame_ellipse_t, "pen.frame_ellipse" );
  declareProcedure( pen_fill_ellipse_t, "pen.fill_ellipse" );

  declareProcedure( pen_new_screen_canvas_t, "pen.new_screen_canvas" );
  declareProcedure( pen_new_window_canvas_t, "pen.new_window_canvas" );
  declareProcedure( pen_new_canvas_t, "pen.new_canvas" );
  declareProcedure( pen_set_title_t, "pen.set_title" );

  declareProcedure( pen_clip_rect_t, "pen.clip_rect" );

  -- Pen.StartupPen;
end StartupPen;

procedure ShutdownPen is
begin
  if penRunning then
     Pen.ShutdownPen;
     penRunning := false;
  end if;
end ShutdownPen;

end parser_pen;
