⟦ec5d8c795⟧

TextFile

/*          Hey EMACS, this is -*- C -*- code!                 */

/****************************************************************
*                                                               *
*                         Copyright (c) 1986                    *
*               Massachusetts Institute of Technology           *
*                                                               *
* This material was developed by the Scheme project at the      *
* Massachusetts Institute of Technology, Department of          *
* Electrical Engineering and Computer Science.  Permission to   *
* copy this software, to redistribute it, and to use it for any *
* purpose is granted, subject to the following restrictions and *
* understandings.                                               *
*                                                               *
* 1. Any copy made of this software must include this copyright *
* notice in full.                                               *
*                                                               *
* 2. Users of this software agree to make their best efforts (a)*
* to return to the MIT Scheme project any improvements or       *
* extensions that they make, so that these may be included in   *
* future releases; and (b) to inform MIT of noteworthy uses of  *
* this software.                                                *
*                                                               *
* 3.  All materials developed as a consequence of the use of    *
* this software shall duly acknowledge such use, in accordance  *
* with the usual standards of acknowledging credit in academic  *
* research.                                                     *
*                                                               *
* 4. MIT has made no warrantee or representation that the       *
* operation of this software will be error-free, and MIT is     *
* under no obligation to provide any services, by way of        *
* maintenance, update, or otherwise.                            *
*                                                               *
* 5.  In conjunction with products arising from the use of this *
* material, there shall be no use of the name of the            *
* Massachusetts Institute of Technology nor of any adaptation   *
* thereof in any advertising, promotional, or sales literature  *
* without prior written consent from MIT in each case.          *
*                                                               *
****************************************************************/

#include "scheme.h"
#include "primitive.h"
#include "flonum.h"
#include <starbase.c.h>


\f


/* Bobcat graphics primitives. Interface to the Starbase package*/

#define YES			    1
#define NO			    0

#define Check_Graphics_Status()	        				\
        if (graphics_initialized == NO)					\
        { fprintf(stderr, "You have not yet initialized graphics.\n");	\
 	  Primitive_Error(ERR_EXTERNAL_RETURN);				\
        }

#define If_Error(Err)                                                   \
        if (Err == 1)                                                   \
        Primitive_Error(ERR_ARG_1_WRONG_TYPE);                          \
	if (Err == 2)                                                   \
 	Primitive_Error(ERR_ARG_2_WRONG_TYPE);

/* Screen Attributes */

#define XMIN -512.0
#define YMIN -384.0
#define ZMIN    0.0
#define XMAX  512.0
#define YMAX  384.0
#define ZMAX    0.0

#define DEFAULT_REPLACEMENT_RULE 3

/* Book keeping variables */

static int screen_handle;
static int first_time = YES;
static int graphics_initialized = NO;
static long replacement_rule = DEFAULT_REPLACEMENT_RULE;
static float xposition, yposition;

\f



Get_Position(ppos1, ppos2, arg1, arg2)
fast Pointer arg1, arg2;
float *ppos1, *ppos2;
{ long temp;
  if (Type_Code(arg1) == TC_FIXNUM)
  { Sign_Extend(arg1, temp);
    *ppos1 = (float) temp;
  }
  else if (Type_Code(arg1) != TC_BIG_FLONUM) return(1);
  else *ppos1 = (float) Get_Float(arg1);
  if (Type_Code(arg2) == TC_FIXNUM)
  { Sign_Extend(arg2, temp);
    *ppos2 = (float) temp;
  }
  else if (Type_Code(arg2) != TC_BIG_FLONUM) return(2);
  else *ppos2 = (float) Get_Float(arg2);
  return(0);
}

/* (GRAPHICS_CLEAR)
      Clear the graphics section of the screen.
      An internal C procedure does the real work.
*/
Define_Primitive(Prim_Graphics_Clear, 0, "GRAPHICS-CLEAR")
{ Primitive_0_Args();
  Check_Graphics_Status();
  C_Clear_Graphics();
  return NIL;
}

/* This can be called from C. Uses the Starbase CLEAR_VIEW_SURFACE
   procedure. Clears the Starbase default area.
*/

C_Clear_Graphics()
{
  xposition = 0.0;
  yposition = 0.0;
  move2d(screen_handle, xposition, yposition);
  clear_view_surface(screen_handle);
  make_picture_current(screen_handle);
}

\f


/* (GRAPHICS_MOVE ARG1 ARG2)
      Uses the Starbase routine MOVE2D to pick up the pen and move
      to the position indicated by ARG1 and ARG2.  Both must be 
      Scheme FIXNUMs or FLONUMs.
*/
Define_Primitive(Prim_Graphics_Move, 2, "GRAPHICS-MOVE")
{ float pos1, pos2;
  int Error_Number;
  Primitive_2_Args();
  Check_Graphics_Status();
  Error_Number = Get_Position(&pos1, &pos2, Arg1, Arg2);
  If_Error(Error_Number)
  xposition = pos1;
  yposition = pos2;
  move2d(screen_handle, xposition, yposition);
  make_picture_current(screen_handle);
  return NIL;
}
\f


/* (GRAPHICS_DRAW ARG1 ARG2)
      Uses the Starbase routine DRAW2D to first make sure the current
      pen is down and uses the current line type to draw to position
      indicated by ARG1 and ARG2.
*/
Define_Primitive(Prim_Graphics_Draw, 2, "GRAPHICS-DRAW")
{ float pos1, pos2;
  int Error_Number;
  Primitive_2_Args();
  Check_Graphics_Status();
  Error_Number = Get_Position(&pos1, &pos2, Arg1, Arg2);
  If_Error(Error_Number)

  xposition = pos1;
  yposition = pos2;
  draw2d(screen_handle, xposition, yposition);
  make_picture_current(screen_handle);
  return NIL;
}

Define_Primitive(Prim_Graphics_Circle, 3, "GRAPHICS-CIRCLE")
{ register float center_x, center_y;
  register float x, y, temp1, temp2, temp3, temp4; 
  register float phi, nphi, phiy;
  int irad;
  int Error_Number;
  Primitive_3_Args();
  Check_Graphics_Status();
  Error_Number = Get_Position(&center_x, &center_y, Arg1, Arg2);
  If_Error(Error_Number)

  if (Type_Code(Arg3) != TC_BIG_FLONUM) 
    { if (Type_Code(Arg3) == TC_FIXNUM)
	{ Sign_Extend(Get_Integer(Arg3),irad);
	  x = (float) irad;}
      else 
	{ Primitive_Error(ERR_ARG_2_WRONG_TYPE);}}
  else 
    { x = Get_Float(Arg3);}

  y   = 0.0;
  phi = 0.0;

  do {
    temp1 = center_x + x;
    temp2 = center_x - x;
    temp3 = center_y + y;
    temp4 = center_y - y;

    plot_pixel(temp1, temp3);
    plot_pixel(temp1, temp4);
    plot_pixel(temp2, temp3);
    plot_pixel(temp2, temp4);

    temp1 = center_x + y;
    temp2 = center_x - y;
    temp3 = center_y + x;
    temp4 = center_y - x;

    plot_pixel(temp1, temp3);
    plot_pixel(temp1, temp4);
    plot_pixel(temp2, temp3);
    plot_pixel(temp2, temp4);

    nphi = phi + y + y + 1.0;
    phiy = ((nphi - x) - x) + 1.0;

    if ((x < y) || (x == y)) break;

    if (fabs(phiy) < fabs(nphi))
      { phi = phiy;
	x = x - 1.0;
	y = y + 1.0;}
    else
      { phi = nphi;
	y = y + 1.0;}
  }
  while (TRUE);
  
  xposition = x;
  yposition = y;
  make_picture_current(screen_handle);
  return NIL;
}

plot_pixel(x,y)
float x,y;
{ move2d(screen_handle, x,y);
  draw2d(screen_handle, x,y);
}

\f


/* (GRAPHICS_PIXEL ARG1 ARG2)
      This routine plots one point on the screen at ARG1, ARG2.  Again,
      ARG1 and ARG2 must FIXNUMs or FLONUMs.
*/
Define_Primitive(Prim_Graphics_Pixel, 2, "GRAPHICS-PIXEL")
{ float pos1, pos2;
  int Error_Number;
  long rule;
  Primitive_2_Args();
  Check_Graphics_Status();
  Error_Number = Get_Position(&pos1, &pos2, Arg1, Arg2);
  If_Error(Error_Number)
  xposition = pos1;
  yposition = pos2;
  move2d(screen_handle, xposition, yposition);
  draw2d(screen_handle, xposition, yposition);
  make_picture_current(screen_handle);
  return NIL;
}
\f


/* (GRAPHICS_SET_LINE STYLE)
      Used to change the style of the line to dashes or dots and 
      dashes or whatever.  Uses Starbase LINE_TYPE procedure.
*/
Define_Primitive(Prim_Graphics_Set_Line, 1, "GRAPHICS-SET-LINE-STYLE")
{ long type;
  Primitive_1_Arg();
  Check_Graphics_Status();
  Arg_1_Type(TC_FIXNUM);
  type = (long) Get_Integer(Arg1);
  line_type(screen_handle, type);
  return NIL;
}

/* (GRAPHICS_SET_LINE COLOR)
      Used to change the style of the line to dashes or dots and 
      dashes or whatever.  Uses Starbase LINE_COLOR_INDEX procedure.
*/
Define_Primitive(Prim_Graphics_Set_Color, 1, "GRAPHICS-SET-LINE-COLOR")
{ long color_index;
  Primitive_1_Arg();
  Check_Graphics_Status();
  Arg_1_Type(TC_FIXNUM);
  color_index = (long) Get_Integer(Arg1);
  line_color_index(screen_handle, color_index);
  text_color_index(screen_handle, color_index);
  return NIL;
}

/* (GRAPHICS_SET_DRAWING_MODE MODE)
      Used to change the replacment rule when drawing.
*/
Define_Primitive(Prim_Graphics_Set_Drawing_Mode, 1, "GRAPHICS-SET-DRAWING-MODE")
{ long rule;
  Primitive_1_Arg();
  Check_Graphics_Status();
  Arg_1_Type(TC_FIXNUM);
  rule = (long) Get_Integer(Arg1);
  if (rule != replacement_rule)
  { replacement_rule = rule;
    drawing_mode(screen_handle, replacement_rule);
  }
  return NIL;
}
\f


/* (GRAPHICS_DONE)
      When finished user will call this routine to finish things up and
      restore the terminal to normal operating conditions.
*/
Define_Primitive(Prim_Graphics_Done, 0, "GRAPHICS-DONE")
{ Primitive_0_Args();
  C_Clear_Graphics();
  if (graphics_initialized == YES)
  { gclose(screen_handle);
  }
  graphics_initialized = NO;
  first_time = YES;
  return NIL;
}
\f



/* (GRAPHICS_POSITION)
      Returns in cons cell the current pen position on the graphics
      screen.  The position is kept in C static variables.
*/
Define_Primitive(Prim_Graphics_Position, 0, "GRAPHICS-POSITION")
{ Pointer *Cons_Cell;
  double floor();
  Primitive_0_Args();
  Check_Graphics_Status();
  Cons_Cell = Free;
  Primitive_GC_If_Needed(Free + 2);
  Free += 2;
  Store_Reduced_Flonum_Result((double) xposition, Cons_Cell[CONS_CAR]);
  Store_Reduced_Flonum_Result((double) yposition, Cons_Cell[CONS_CDR]);
  return Make_Pointer(TC_LIST, Cons_Cell); 
}
\f



/* (GRAPHICS_INITIALIZE)
      Opens the screen devices and performs necessary initialization.
*/
Define_Primitive(Prim_Graphics_Initialize, 0, "GRAPHICS-INITIALIZE")
{ Primitive_0_Args();
  if (first_time == NO)
  { 
    graphics_initialized = YES;
  }
  else
  { /* Leave the screen attributes as is; no initialization */
    screen_handle = gopen("/dev/crt", OUTDEV, "hp300h", 0);
    if ( screen_handle == -1 ) 
      Primitive_Error(ERR_EXTERNAL_RETURN);
    graphics_initialized = YES;
    first_time = NO;
  }
  /* Initialize the Screen */
  vdc_extent(screen_handle, XMIN, YMIN, ZMIN, XMAX, YMAX, ZMAX);
  clip_rectangle(screen_handle, XMIN, XMAX, YMIN, YMAX);
  drawing_mode(screen_handle, DEFAULT_REPLACEMENT_RULE);
  replacement_rule = DEFAULT_REPLACEMENT_RULE;
  text_alignment(screen_handle,TA_NORMAL_HORIZONTAL,TA_NORMAL_VERTICAL,0.0,0.0);
  C_Clear_Graphics();
  return NIL;
}
\f


/* (GRAPHICS_LABEL STRING)
      Prints a string label at the current pen position.  The label is
      written according to the current letter type as defined by 
      GRAPHICS_LETTER.
*/
Define_Primitive(Prim_Graphics_Label, 1, "GRAPHICS-LABEL")
{ Primitive_1_Arg();
  Check_Graphics_Status();
  Arg_1_Type(TC_CHARACTER_STRING);
  text2d(screen_handle, xposition, yposition,
	 Scheme_String_To_C_String(Arg1), VDC_TEXT, FALSE);
  make_picture_current(screen_handle);
  return NIL;
}

/* (GRAPHICS_SET_LETTER HEIGHT, ASPECT, and SLANT)
      This routine will change the way in which letters are drawn 
      by Starbase.
*/
Define_Primitive(Prim_Graphics_Set_Letter, 3, "GRAPHICS-SET-LETTER")
{ float height,aspect,slant;
  long intemp;
  int i = 0;
  Pointer temp;
  Primitive_3_Args();
  Check_Graphics_Status();

  if (Type_Code(Arg1) == TC_FIXNUM)
    { Sign_Extend(Arg1, intemp);
      height = (float) intemp;
    }
  else if (Type_Code(Arg1) ==  TC_BIG_FLONUM)
    height = (float) Get_Float(Arg1);
  else Primitive_Error(ERR_ARG_1_WRONG_TYPE);

  if (Type_Code(Arg2) == TC_FIXNUM)
    { Sign_Extend(Arg2, intemp);
      aspect = (float) intemp;
    }
  else if (Type_Code(Arg2) ==  TC_BIG_FLONUM)
    aspect = (float) Get_Float(Arg2);
  else Primitive_Error(ERR_ARG_2_WRONG_TYPE);

  if (Type_Code(Arg3) == TC_FIXNUM)
    { Sign_Extend(Arg3, intemp);
      slant = (float) intemp;
    }
  else if (Type_Code(Arg3) ==  TC_BIG_FLONUM)
    slant = (float) Get_Float(Arg3);
  else Primitive_Error(ERR_ARG_3_WRONG_TYPE);

  character_height(screen_handle, height);
  character_expansion_factor(screen_handle, aspect);
  character_slant(screen_handle, slant);
  make_picture_current(screen_handle);
  return NIL;
}

/* (GRAPHICS_SET_ROTATION ANGLE)
      Sets the character path of graphics text.
*/
Define_Primitive(Prim_Graphics_Set_Rotation, 1 , "GRAPHICS-SET-ROTATION")
{ float angle;
  long intemp;
  int path_style;
  Primitive_1_Arg();

  if (Type_Code(Arg1) == TC_FIXNUM)
    { Sign_Extend(Arg1, intemp);
      angle = (float) intemp;
    }
  else if (Type_Code(Arg1) ==  TC_BIG_FLONUM)
    angle = (float) Get_Float(Arg1);
  else Primitive_Error(ERR_ARG_3_WRONG_TYPE);

  if ( angle > ((float) 315) || angle <= ((float) 45) ) 
    path_style = PATH_RIGHT;
  else if ( angle > ((float) 45) && angle <= ((float) 135) )
    path_style = PATH_DOWN;
  else if ( angle > ((float) 135) && angle <= ((float) 225) ) 
    path_style = PATH_LEFT;
  else if ( angle > ((float) 225) && angle <= ((float) 315) ) 
    path_style = PATH_UP;
  text_path(screen_handle, path_style);
  return NIL;
}


/* (GRAPHICS_SCL3) Not done for Bobcat yet.
      One must call this routine to set up for three dimensional graphics.
      After calling this, the user can use GRAPHICS_SPLOT3 to draw in the 
      three dimensional region set up here.
* /
Define_Primitive(Prim_Graphics_Scl3, 2, "GRAPHICS-SCL3")
{ float args[8];
  long ibox;
  int i = 0;
  Pointer temp;
  Primitive_2_Args();
  Check_Graphics_Status();
  Arg_1_Type(TC_LIST);
  Arg_2_Type(TC_FIXNUM);
  while (Type_Code(Arg1) == TC_LIST)
  { temp = Vector_Ref(Arg1, CONS_CAR);
    if (Type_Code(temp) == TC_FIXNUM)
    { long intemp;
      Sign_Extend(temp, intemp);
      args[i++] = (float) intemp;
    }
    else if (Type_Code(temp) == TC_BIG_FLONUM)
      args[i++] = (float) Get_Float(temp);
    else Primitive_Error(ERR_ARG_1_WRONG_TYPE);
    Arg1 = Vector_Ref(Arg1, CONS_CDR);
  }
  if (i != 9)
    Primitive_Error(ERR_WRONG_NUMBER_OF_ARGUMENTS);
  ibox = (long) Get_Integer(Arg2);
  scl3_(&args[0], &args[1], &args[2], &args[3], &args[4],
        &args[5], &args[6], &args[7], &args[8], &ibox);
  tsend_();
  return NIL;
}
\f


/ * (GRAPHICS_SPLOT3 LIST_OF_COORDS PEN)
      This procedure allows one to draw in a three dimensional region as
      defined by the arguments given to SCL3.
* /
Define_Primitive(Prim_Graphics_Splot3, 2, "GRAPHICS-SPLOT3")
{ float args[2];
  int i = 0;
  long ipen;
  Pointer temp;
  Primitive_2_Args();
  Check_Graphics_Status();
  Arg_1_Type(TC_LIST);
  Arg_2_Type(TC_FIXNUM);
  while (Type_Code(Arg1) == TC_LIST)
  { temp = Vector_Ref(Arg1, CONS_CAR);
    if (Type_Code(temp) == TC_FIXNUM)
    { long intemp;
      Sign_Extend(temp, intemp);
      args[i++] = (float) intemp;
    }
    else if (Type_Code(temp) == TC_BIG_FLONUM)
      args[i++] = (float) Get_Float(temp);
    else Primitive_Error(ERR_ARG_1_WRONG_TYPE);
    Arg1 = Vector_Ref(Arg1, CONS_CDR);
  }
  if (i != 3)
   Primitive_Error(ERR_WRONG_NUMBER_OF_ARGUMENTS);
  ipen = (long) Get_Integer(Arg2);
  splot3_(&args[0], &args[1], &args[2], &ipen);
  tsend_();
  return NIL;
}
*/
DataMuseum.dk

DKUUG/EUUG Conference tapes

⟦ec5d8c795⟧ TextFile

Derivation

TextFile
