home *** CD-ROM | disk | FTP | other *** search
/ Dream 44 / Amiga_Dream_44.iso / RiscPc / programmation / scm4e2.arc / !Scm / c / archi
Text File  |  1995-08-03  |  13KB  |  640 lines
  1. /*
  2. | Acorn Archimedes Extensions for GNU Scheme Interpreter
  3. | This code is subject to the GPL - see below...
  4. | (C) Al Slater 1994->
  5. | ams@csd.abdn.ac.uk
  6. */
  7.  
  8.  
  9. #include        "scm.h"         /* includes scmfig.h as well    */
  10. #include        "patchlvl.h"    /* Guess...                     */
  11.  
  12. #include    <math.h>    /* for turtle stuff */
  13. #include    <sys/os.h>    /* archi os stuff */
  14.  
  15.  
  16. /* --- internal OS definitions */
  17. #define OS_WriteC          0x0
  18. #define OS_ReadC          0x4
  19. #define OS_RemoveCursors      0x36
  20. #define OS_RestoreCursors     0x37
  21. #define OS_Plot              0x45
  22.  
  23. /* --- globals for turtling --- */
  24. #define TDN 360
  25.  
  26. #ifndef  PI
  27. # undef  PI
  28. # define PI 3.141592654
  29. #endif   /* PI */
  30.  
  31. static float CO[TDN];
  32. static float SI[TDN];
  33. float TurtleX,TurtleY;       /* where are we on screen? */
  34. int TurtleDir;             /* direction as int */
  35. int penup;             /* pen up or down? */
  36. int o_heading,home_x,home_y;
  37.  
  38. /* names of functions */
  39. static  char    s_arc_cls[]              = "cls";
  40. static  char    s_arc_clg[]              = "clg";
  41. static  char    s_arc_circle[]           = "circle";
  42. static  char    s_arc_draw[]             = "draw";
  43. static  char    s_arc_fill[]             = "fill";
  44. static  char    s_arc_gcol[]             = "gcol";
  45. static  char    s_arc_get[]              = "get";
  46. static    char    s_arc_graphics_origin[]  = "graphics-origin!";
  47. static  char    s_arc_mode[]             = "mode";
  48. static  char    s_arc_move[]             = "move";
  49. static  char    s_arc_plot[]             = "plot";
  50. static  char    s_arc_point[]            = "point";
  51. static    char    s_arc_remove_cursor[]    = "remove-cursor!";
  52. static  char    s_arc_restore_cursor[]   = "restore-cursor!";
  53. static  char    s_arc_text_colour[]      = "text-colour!";
  54. static  char    s_arc_text_cursor[]     = "text-cursor!";
  55. static  char    s_arc_vdu[]              = "vdu";
  56. static  char    s_arc_vdu25[]         = "vdu25";
  57. static  char    s_arc_vdu29[]         = "vdu29";
  58. static  char    s_arc_wait[]             = "wait";
  59. static  char    s_arc_wrc2[]             = "_wrc2";
  60. static  char    s_arc_swi[]              = "swi";
  61.  
  62. /* --- turtle routines */
  63. static  char    s_arc_forward[]          = "forward";
  64. static  char    s_arc_init_turtle[]     = "init-turtle";
  65. static  char    s_arc_turn[]         = "turn";
  66. static  char    s_arc_pen_up[]         = "pen-up";
  67. static    char    s_arc_pen_down[]     = "pen-down";
  68. static  char    s_arc_pen_upp[]          = "pen-up?";
  69. static  char    s_arc_pen_downp[]     = "pen-down?";
  70. static    char    s_arc_home[]         = "home";
  71.  
  72. /*
  73. | Code for actual scheme functions starts here
  74. */
  75.  
  76. /* perform OS_WriteC */
  77. void os_wrc(x)
  78. int x;
  79. {
  80.   int reg[10];
  81.   reg[0] = x;
  82.   os_swi(OS_WriteC,reg);
  83. }
  84.  
  85. /* change the video mode to whatever */
  86. SCM arc_mode(n)
  87. SCM n;
  88. {
  89.   int m;
  90.  
  91.   ASSERT( INUMP(n),n,ARG1,s_arc_mode ); /* integers only */
  92.           m = INUM(n);
  93.  
  94.   os_wrc(22);
  95.   os_wrc(m);
  96.  
  97.   return MAKINUM( m );
  98. }
  99.  
  100. /* generic plot command */
  101. SCM arc_vdu25(type,x,y)
  102. SCM type,x,y;
  103. {
  104.   int atype;
  105.   unsigned ax,ay;
  106.  
  107.   ASSERT( INUMP(type),type,ARG1,s_arc_vdu25 );
  108.   ASSERT( INUMP(x),x,ARG2,s_arc_vdu25 );
  109.   ASSERT( INUMP(y),y,ARG3,s_arc_vdu25 );
  110.  
  111.   atype = INUM(type);
  112.   ax = INUM(x); ay = INUM(y);
  113.  
  114.   os_wrc(25); /* vdu 25 == plot */
  115.   os_wrc(atype);
  116.  
  117.   os_wrc(ax);
  118.   ax >>= 8;
  119.   os_wrc(ax);
  120.  
  121.   os_wrc(ay);
  122.   ay >>= 8;
  123.   os_wrc(ay);
  124.  
  125.   return MAKINUM(atype);
  126. }
  127.  
  128. SCM arc_vdu29(x,y)
  129. SCM x,y;
  130. {
  131.   int byte;
  132.   unsigned ax,ay;
  133.  
  134.   ASSERT( INUMP(x),x,ARG1,s_arc_vdu29 );
  135.   ASSERT( INUMP(y),y,ARG2,s_arc_vdu29 );
  136.  
  137.   ax = INUM(x); ay = INUM(y);
  138.   os_wrc(29);
  139.  
  140.   byte = ax;
  141.   os_wrc(byte);
  142.   byte >>= 8;
  143.   os_wrc(byte);
  144.   byte = ay;
  145.   os_wrc(byte);
  146.   byte >>= 8;
  147.   os_wrc(byte);
  148.  
  149.   return UNSPECIFIED;
  150. }
  151.  
  152. SCM arc_wrc2(x)
  153. SCM x;
  154. {
  155.   int byte;
  156.   ASSERT ( INUMP(x), x, ARG1, s_arc_wrc2 );
  157.  
  158.   byte = INUM(x);
  159.  
  160.   os_wrc(byte);
  161.   byte >>= 8;
  162.   os_wrc(byte);
  163.  
  164.   return UNSPECIFIED;
  165. }
  166.  
  167. SCM arc_text_cursor(x,y)
  168. SCM x,y;
  169. {
  170.   int ax,ay;
  171.  
  172.   ASSERT( INUMP(x),x,ARG1,s_arc_vdu29 );
  173.   ASSERT( INUMP(y),y,ARG2,s_arc_vdu29 );
  174.  
  175.   ax = INUM(x); ay = INUM(y);
  176.   os_wrc(31);     /* position text cursor */
  177.   os_wrc(ax);     /* x */
  178.   os_wrc(ay);     /* y */
  179.  
  180.   return UNSPECIFIED;
  181. }
  182.  
  183. SCM arc_text_colour(i)
  184. SCM i;
  185. {
  186.   int ai;
  187.   ASSERT( INUMP(i),i,ARG1,s_arc_text_colour );
  188.   ai = INUM (i);
  189.   os_wrc(17);   /* vdu 17,... == change current text colour */
  190.   os_wrc(ai);
  191.   return MAKINUM( ai );
  192. }
  193.  
  194. SCM arc_remove_cursor()
  195. {
  196.   int reg[10];
  197.   os_swi(OS_RemoveCursors,reg);
  198.   return UNSPECIFIED;
  199. }
  200.  
  201. SCM arc_restore_cursor()
  202. {
  203.   int reg[10];
  204.   os_swi(OS_RestoreCursors,reg);
  205.   return UNSPECIFIED;
  206. }
  207.  
  208. SCM arc_plot(p,x,y)
  209. SCM p,x,y;
  210. {
  211.   int reg[10];
  212.   ASSERT( INUMP(p),p,ARG1,s_arc_plot );
  213.   ASSERT( INUMP(x),x,ARG2,s_arc_plot );
  214.   ASSERT( INUMP(y),y,ARG3,s_arc_plot );
  215.  
  216.   reg[0] = INUM(p); /* plot code */
  217.   reg[1] = INUM(x); /* x coord */
  218.   reg[2] = INUM(y); /* y coord */
  219.  
  220.   os_swi(OS_Plot,reg);
  221.  
  222.   return UNSPECIFIED;
  223. }
  224.  
  225. SCM arc_move(x,y)
  226. SCM x,y;
  227. {
  228.   int ax,ay,reg[10];
  229.   ASSERT( INUMP(x),x,ARG1,s_arc_move );
  230.   ASSERT( INUMP(y),y,ARG2,s_arc_move );
  231.  
  232.   ax = INUM(x); ay = INUM(y);
  233.   reg[0] = 4;        /* PLOT code for a move */
  234.   reg[1] = ax;        /* x coord */
  235.   reg[2] = ay;      /* y coord */
  236.   os_swi(OS_Plot,reg);
  237.  
  238.   return UNSPECIFIED;
  239. }
  240.  
  241. SCM arc_circle(x,y,rad)
  242. SCM x,y,rad;
  243. {
  244.   int ax,ay,arad,reg[10];
  245.  
  246.   ASSERT( INUMP(x),x,ARG1,s_arc_circle );
  247.   ASSERT( INUMP(y),y,ARG2,s_arc_circle );
  248.   ASSERT( INUMP(rad),rad,ARG3,s_arc_circle);
  249.  
  250.   ax = INUM( x );
  251.   ay = INUM( y );
  252.   arad = INUM( rad );
  253.  
  254.   reg[0] = 4;        /* PLOT code for a move */
  255.   reg[1] = ax;        /* x coord */
  256.   reg[2] = ay;      /* y coord */
  257.   os_swi(OS_Plot,reg);
  258.  
  259.   reg[0] = 145;
  260.   reg[1] = arad;
  261.   reg[2] = 0;
  262.   os_swi(OS_Plot,reg);
  263.  
  264.   return UNSPECIFIED;
  265. }
  266.  
  267. SCM arc_wait()
  268. {
  269.   int reg[10];
  270.   reg[0] = 19;
  271.   os_swi(0x6,reg);
  272.   return UNSPECIFIED;
  273. }
  274.  
  275. SCM arc_gcol(a,c)
  276. SCM a,c;
  277. {
  278.   int aa,ac;
  279.  
  280.   ASSERT( INUMP(a),a,ARG1,s_arc_gcol );
  281.   ASSERT( INUMP(c),c,ARG2,s_arc_gcol );
  282.   aa = INUM(a);
  283.   ac = INUM(c);
  284.  
  285.   os_wrc(18);        /* gcol == vdu 18,..,.. */
  286.   os_wrc(aa);        /* action code */
  287.   os_wrc(ac);        /* colour */
  288.  
  289.   return UNSPECIFIED;
  290. }
  291.  
  292. SCM arc_cls()
  293. {
  294.   os_wrc(12); /* clear screen */
  295.   return UNSPECIFIED;
  296. }
  297.  
  298. SCM arc_clg()
  299. {
  300.   os_wrc(16); /* clear gfx screen */
  301.   return UNSPECIFIED;
  302. }
  303.  
  304. SCM arc_fill(x,y)
  305. SCM x,y;
  306. {
  307.   int ix,iy,reg[10];
  308.   ASSERT( INUMP(x),x,ARG1,s_arc_fill );
  309.   ASSERT( INUMP(y),y,ARG2,s_arc_fill );
  310.  
  311.   ix = INUM(x);
  312.   iy = INUM(y);
  313.  
  314.   reg[0] = 133;
  315.   reg[1] = ix;
  316.   reg[2] = iy;
  317.   os_swi(OS_Plot,reg);
  318.  
  319.   return UNSPECIFIED;
  320. }
  321.  
  322. SCM arc_point(x,y)
  323. SCM x,y;
  324. {
  325.   int ix,iy,reg[10];
  326.   ASSERT ( INUMP(x), x, ARG1, s_arc_point );
  327.   ASSERT ( INUMP(y), y, ARG2, s_arc_point );
  328.   ix = INUM(x);
  329.   iy = INUM(y);
  330.   reg[0] = 69; /* plot code for point */
  331.   reg[1] = ix;
  332.   reg[2] = iy;
  333.  
  334.   os_swi(OS_Plot,reg);
  335.  
  336.   return MAKINUM( reg[0] );
  337. }
  338.  
  339. SCM arc_draw(x,y)
  340. SCM x,y;
  341. {
  342.   int reg[10],ix,iy;
  343.   ASSERT ( INUMP(x), x, ARG1, s_arc_draw );
  344.   ASSERT ( INUMP(y), y, ARG2, s_arc_draw );
  345.  
  346.   ix = INUM(x);
  347.   iy = INUM(y);
  348.   reg[0] = 5;
  349.   reg[1] = ix;
  350.   reg[2] = iy;
  351.   os_swi(OS_Plot,reg);
  352.  
  353.   return UNSPECIFIED;
  354. }
  355.  
  356. /* straight interface onto vdu driver */
  357. SCM arc_vdu(n)
  358. SCM n;
  359. {
  360.   int in;
  361.   ASSERT( INUMP(n), n, ARG1, s_arc_vdu );
  362.   in = INUM(n);
  363.   os_wrc(in);
  364.   return MAKINUM ( in );
  365. }
  366.  
  367. SCM arc_get()
  368. {
  369.   int reg[10];
  370.   os_swi(OS_ReadC,reg);
  371.   return MAKINUM( reg[0] );
  372. }
  373.  
  374. /* --- end of C code for extensions */
  375. /* --- code for turtling start here --- */
  376. SCM arc_forward(n)
  377. SCM n;
  378. {
  379.   int in,reg[10];
  380.  
  381.   ASSERT( INUMP(n), n, ARG1, s_arc_forward );
  382.  
  383.   in = INUM(n);
  384.  
  385.   TurtleX += (in*CO[TurtleDir]);
  386.   TurtleY += (in*SI[TurtleDir]);
  387.  
  388.   reg[0] = penup ? 4 : 5;
  389.   reg[1] = floor(TurtleX);
  390.   reg[2] = floor(TurtleY);
  391.   os_swi(OS_Plot,reg);
  392.  
  393.   return UNSPECIFIED;
  394. }
  395.  
  396. SCM arc_init_turtle(x,y,h)
  397. SCM x,y,h;
  398. {
  399.   int reg[10];
  400.  
  401.   ASSERT( INUMP(x), x, ARG1, s_arc_init_turtle );
  402.   ASSERT( INUMP(y), y, ARG2, s_arc_init_turtle );
  403.   ASSERT( INUMP(h), h, ARG3, s_arc_init_turtle );
  404.  
  405.   home_x = INUM(x); home_y = INUM(y);
  406.   o_heading = INUM(h);
  407.   if (o_heading < 0) o_heading = 0;
  408.   if (o_heading > 360) o_heading = 0;
  409.  
  410.   TurtleX = (float)home_x;
  411.   TurtleY = (float)home_y;
  412.   TurtleDir = o_heading;
  413.  
  414.   /* now move to where we initted the graphics pen to.. */
  415.   reg[0] = 4;
  416.   reg[1] = home_x;
  417.   reg[2] = home_y;
  418.   os_swi(OS_Plot,reg);
  419.  
  420.   return UNSPECIFIED;
  421. }
  422.  
  423. SCM arc_turn(n)
  424. SCM n;
  425. {
  426.   int in;
  427.   ASSERT ( INUMP(n), n, ARG1, s_arc_turn );
  428.   in = INUM(n);
  429.  
  430.   /* add on if we can turn... */
  431.   TurtleDir += (in % TDN);
  432.  
  433.   /* oops! too far! - make it sensible... */
  434.   if (TurtleDir >= TDN) TurtleDir = (TurtleDir % TDN);
  435.   else if (TurtleDir < 0) TurtleDir = (TDN+TurtleDir) % TDN;
  436.  
  437.   return MAKINUM(TurtleDir); /* where we are currently pointing */
  438. }
  439.  
  440. SCM arc_pen_up() { penup = 1; return UNSPECIFIED; }
  441. SCM arc_pen_down() { penup = 0; return UNSPECIFIED; }
  442.  
  443. SCM arc_pen_upp() {
  444.     if (penup == 1)
  445.         return(BOOL_T) ;
  446.     else
  447.         return(BOOL_F);
  448. }
  449.  
  450. SCM arc_pen_downp() {
  451.     if (penup == 0)
  452.         return (BOOL_T);
  453.     else
  454.         return (BOOL_F);
  455. }
  456.  
  457. SCM arc_home() {
  458.  
  459.     int reg[10];
  460.     reg[0] = 4;
  461.     reg[1] = home_x;
  462.     reg[2] = home_y;
  463.     os_swi(OS_Plot,reg);
  464.  
  465.     TurtleX = home_x;
  466.     TurtleY = home_y;
  467.     TurtleDir = o_heading;
  468.     return UNSPECIFIED;
  469. }
  470.  
  471. SCM arc_swi(number,regs)
  472. SCM number;
  473. SCM regs;
  474. {
  475.   int swiN,no_regs = 0,at = 0;
  476.   int swiregs[10];
  477.   SCM itr = regs;
  478.   SCM res = EOL;
  479.  
  480.   ASSERT(INUMP(number), number, ARG1, s_arc_swi);
  481.   ASSERT(CONSP(regs), regs, ARG2, s_arc_swi);
  482.  
  483.   swiN = INUM(number);
  484.  
  485.   if ((no_regs = ilength(regs)) < 0 || NULLP(regs) || no_regs>10) {
  486.     wta(regs,(char *)ARG2,s_arc_swi);
  487.   }
  488.   do {
  489.     if (INUMP(CAR(itr))) {
  490.       swiregs[at++] = INUM(CAR(itr));
  491.       continue;
  492.     } else if (NIMP(CAR(itr)) && STRINGP(CAR(itr))) {
  493.       swiregs[at++] = (int)CHARS(CAR(itr));
  494.       continue;
  495.     }
  496.   }  while ((itr = CDR(itr)) != EOL);
  497.  
  498.   /* zero remaining, for return tidyness... */
  499.   for(;at<10;at++) swiregs[at] = 0;
  500.  
  501.   os_swi(swiN,swiregs);
  502.  
  503.   for(--at;at>=0;at--) res = cons(MAKINUM(swiregs[at]),res);
  504.  
  505.   return res;
  506. }
  507.  
  508. SCM arc_dehex(str) /* god I'm a lazy bastard >:-) */
  509. SCM str;
  510. {
  511.   char *scanstr;
  512.   int res;
  513.  
  514.   ASSERT( NIMP(str) && STRINGP(str), str, ARG1, "_dehex");
  515.   scanstr = CHARS(str);
  516.   if (*scanstr == '\0') wta(str,(char *)ARG1,"_dehex");
  517.   sscanf(scanstr,"%x",&res);
  518.   return MAKINUM(res);
  519. }
  520.  
  521. SCM arc_dsptr(addr)
  522. SCM addr;
  523. {
  524.   char *ptr;
  525.   /* this ia APPALLING abuse!... */
  526.   ASSERT( INUMP(addr), addr, ARG1, "_dsptr");
  527.   ptr = (char *)INUM(addr);
  528.   return makfromstr(ptr,strlen(ptr));
  529. }
  530.  
  531. /*
  532. SCM arc_intp(str)
  533. SCM str;
  534. {
  535.   char *ptr;
  536.   char *n;
  537.   ASSERT(NIMP(str) && STRINGP(str), str, ARG1, "_intp");
  538.   ptr = CHARS(str);
  539.   n = (char *)malloc(strlen(ptr)+1);
  540.   strcpy(n,ptr);
  541.   return MAKINUM((int)n);
  542. }
  543. */
  544.  
  545. SCM arc_free(ptr)
  546. SCM ptr;
  547. {
  548.   void *aptr;
  549.   ASSERT(INUMP(ptr), ptr, ARG1, "_free");
  550.   aptr = (void *)INUM(ptr);
  551.   free(aptr);
  552.   return UNSPECIFIED;
  553. }
  554.  
  555. SCM arc_makebuf(sz)
  556. SCM sz;
  557. {
  558.   int size;
  559.   char *buffer;
  560.   ASSERT(INUMP(sz), sz, ARG1, "_makebuf");
  561.   size=INUM(sz);
  562.   buffer = (char *)malloc(size+1);
  563.   memset(buffer,' ',size);
  564.   buffer[size] = '\0';
  565.   return MAKINUM((int)buffer);
  566. }
  567.  
  568. /* bind names to functions */
  569. static iproc archi0[] = {
  570.           { s_arc_remove_cursor, arc_remove_cursor },
  571.           { s_arc_restore_cursor, arc_restore_cursor },
  572.           { s_arc_wait, arc_wait },
  573.           { s_arc_cls, arc_cls },
  574.           { s_arc_clg, arc_clg },
  575.           { s_arc_get, arc_get },
  576.           { s_arc_pen_up, arc_pen_up },
  577.           { s_arc_pen_down, arc_pen_down },
  578.           { s_arc_pen_upp, arc_pen_upp },
  579.           { s_arc_pen_downp, arc_pen_downp },
  580.           { s_arc_home, arc_home },
  581.           { 0,0 }
  582. };
  583.  
  584. static iproc archi1[] = {
  585.         { s_arc_mode, arc_mode },
  586.       { s_arc_text_colour, arc_text_colour },
  587.       { s_arc_vdu, arc_vdu },
  588.       { s_arc_wrc2, arc_wrc2 },
  589.       { s_arc_forward, arc_forward },
  590.       { s_arc_turn, arc_turn },
  591.       { "_dehex", arc_dehex },
  592.       { "_dsptr", arc_dsptr },
  593.       /* { "_intp", arc_intp }, */
  594.       { "_free", arc_free },
  595.       { "_makebuf", arc_makebuf },
  596.         { 0,0 }
  597. };
  598.  
  599. static iproc archi2[] = {
  600.           { s_arc_vdu29, arc_vdu29 },
  601.           { s_arc_graphics_origin, arc_vdu29 },
  602.           { s_arc_text_cursor, arc_text_cursor },
  603.           { s_arc_move, arc_move },
  604.           { s_arc_gcol, arc_gcol },
  605.           { s_arc_fill, arc_fill },
  606.           { s_arc_point, arc_point },
  607.           { s_arc_draw, arc_draw },
  608.       { s_arc_swi, arc_swi },
  609.           { 0,0 }
  610. };
  611.  
  612. static iproc archi3[] = {
  613.           { s_arc_vdu25, arc_vdu25 },
  614.           { s_arc_plot, arc_plot },
  615.           { s_arc_circle, arc_circle },
  616.           { s_arc_init_turtle, arc_init_turtle },
  617.       { 0,0 }
  618. };
  619.  
  620. void    init_arcext()
  621. {
  622.   int i;
  623.         init_iprocs( archi0, tc7_subr_0 );
  624.       init_iprocs( archi1, tc7_subr_1 );
  625.       init_iprocs( archi2, tc7_subr_2 );
  626.       init_iprocs( archi3, tc7_subr_3 );
  627.  
  628.       puts( "\nSCM Acorn Archimedes Extensions (C) 1994 ams@csd.abdn.ac.uk\n" );
  629.  
  630.           /* ok now setup turtle stuff.. */
  631.           for (i=0; i<TDN; i++) {
  632.             CO[i] = cos(2*PI*i/TDN);
  633.             SI[i] = sin(2*PI*i/TDN);
  634.           }
  635.           /* pen starts down */
  636.       penup = 0;
  637.       o_heading = home_x = home_y = 0;
  638.  
  639. } /* init_archi() */
  640.