------------------------------------------------------------------------------ -- 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;