home *** CD-ROM | disk | FTP | other *** search
/ Simtel MSDOS 1992 December / simtel1292_SIMTEL_1292_Walnut_Creek.iso / msdos / turbopas / spoc88.arc / SCRHND.ARC / XSCRHND.PRO < prev    next >
Text File  |  1988-06-03  |  16KB  |  591 lines
  1. /*   Listing 3: XSCRHND.PRO   */
  2.  
  3. /****************************************************************
  4.  
  5.      Turbo Prolog Toolbox
  6.      (C) Copyright 1987 Borland International.
  7.  
  8.             SCRHND
  9.             ======
  10.  
  11.  This module implements a screen handler called by:
  12.                
  13.                  scrhnd(TOPLINE,ENDKEY)
  14.  
  15.     TOPLINE = on/off  - determines if there should be a top line
  16.     ENDKEY            - Esc or F10 used to return values
  17. ****************************************************************/
  18. /***************************************************************
  19.  *  Modified 2/5/88 G.Wood
  20.  *  Added capabilities to:
  21.  *    - enable all function keys and define an additional input key
  22.  *    - allow the tab to wrap-around
  23.  *    - correct cursor positioning when an input field is filled,
  24.  *            including wrap-around
  25.  *    - define a back tab function from the middle of an input field
  26.  *
  27.  *  See clauses scr
  28.  *              nextfield
  29.  *              chk_found
  30.  *              prevfield
  31.  ***************************************************************/
  32.  
  33. /*
  34. DOMAINS
  35.   FNAME=SYMBOL
  36.   TYPE = int(); str(); real()
  37.  
  38. DATABASE
  39.   /* Database declarations used in scrhnd */
  40.   insmode            /* Global insertmode */
  41.   actfield(FNAME)        /* Actual field */
  42.   screen(SYMBOL,DBASEDOM)    /* Saving different screens */
  43.   value(FNAME,STRING)        /* value of a field */
  44.   field(FNAME,TYPE,ROW,COL,LEN) /* Screen definition */
  45.   txtfield(ROW,COL,LEN,STRING)
  46.   windowsize(ROW,COL).
  47.   notopline
  48.  
  49.   /* DATABASE PREDICATES USED BY VSCRHND */
  50.   windowstart(ROW,COL)
  51.   mycursord(ROW,COL)
  52.  
  53.   /* Database declarations used in lineinp */
  54.   lineinpstate(STRING,COL)
  55. */
  56.  
  57.  
  58. PREDICATES
  59.   /* SCREEN DRIVER */
  60.   scrhnd(SYMBOL,KEY)
  61.   endkey(KEY)
  62.   scr(KEY)
  63.   writescr
  64.   showcursor
  65.   mkheader
  66.   showoverwrite
  67.  
  68.   ass_val(FNAME,STRING)
  69.   valid(FNAME,TYPE,STRING)
  70.   typeerror
  71.   chng_actfield(FNAME)
  72.   field_action(FNAME)
  73.   field_value(FNAME,STRING)
  74.   noinput(FNAME)
  75.   types(INTEGER,TYPE,STRING)    /* Definition of the known types */
  76.  
  77.  
  78.  /*****************************************************************/
  79.  /*        Create the window                  */
  80.  /* This can be used to create the window automatically from the  */
  81.  /* windowsize predicate.                          */
  82.  /*****************************************************************/
  83.  
  84. PREDICATES
  85.   createwindow(SYMBOL)
  86.  
  87. CLAUSES
  88.   createwindow(off):-
  89.     windowsize(R,C),!,
  90.     R1=R+3, C1=C+3,
  91.     makewindow(81,23,66,"",0,0,R1,C1).
  92.   createwindow(on):-
  93.     windowsize(R,C),!,
  94.     R1=R+3, C1=C+3,
  95.     makewindow(85,112,0,"",0,0,1,C1),
  96.     makewindow(81,23,66,"",1,0,R1,C1).
  97.  
  98.  /*****************************************************************/
  99.  /*        Intermediate predicates                      */
  100.  /*****************************************************************/
  101.  
  102. PREDICATES
  103.   trunc_(LEN,STRING,STRING)
  104.   oldstr(FNAME,STRING)
  105.   settopline(SYMBOL)
  106.  
  107. CLAUSES
  108.   endkey(fkey(10)):-!.
  109.   endkey(esc).
  110.   /*************************************************************
  111.    * Modified 2/5/88 G.Wood
  112.    *  Added clauses to endkey for fkeys 1 thru 9, and
  113.    *    new symbolic key 'plus'. Allows these keys to terminate
  114.    *    the screen handling predicate, scrhnd
  115.    *************************************************************/
  116.   endkey(fkey(1)):-!.
  117.   endkey(fkey(2)):-!.
  118.   endkey(fkey(3)):-!.
  119.   endkey(fkey(4)):-!.
  120.   endkey(fkey(5)):-!.
  121.   endkey(fkey(6)):-!.
  122.   endkey(fkey(7)):-!.
  123.   endkey(fkey(8)):-!.
  124.   endkey(fkey(9)):-!.
  125.   endkey(plus):-!.
  126.  
  127.   trunc_(LEN,STR1,STR2):-str_len(STR1,L1),L1>LEN,!,
  128.                         frontstr(LEN,STR1,STR2,_).
  129.   trunc_(_,STR,STR).
  130.  
  131.   settopline(_):-retract(notopline),fail.
  132.   settopline(off):-!,assert(notopline).
  133.   settopline(_).
  134.  
  135.   oldstr(FNAME,S):-    value(FNAME,S),!.
  136.   oldstr(_,"").
  137.  
  138.   ass_val(FNAME,_):- retract(value(FNAME,_)),fail.
  139.   ass_val(FNAME,VAL):-VAL><"",assert(value(FNAME,VAL)),fail.
  140.   ass_val(_,_).
  141.  
  142.   chng_actfield(_):-typeerror,!,fail.
  143.   chng_actfield(_):-
  144.     retract(actfield(_)),fail.
  145.   chng_actfield(FNAME):-
  146.     assert(actfield(FNAME)).
  147.  
  148.   typeerror:-
  149.     actfield(FNAME),
  150.     field(FNAME,TYPE,_,_,_),
  151.     value(FNAME,VAL),
  152.     not(valid(FNAME,TYPE,VAL)),
  153.     beep,!.
  154.  
  155.   valid(_,str,_).
  156.   valid(_,int,STR):-str_int(STR,_).
  157.   valid(_,real,STR):-str_real(STR,_).
  158.  
  159.   /* The known types */
  160.   types(1,int,"integer").
  161.   types(2,real,"real").
  162.   types(3,str,"string").
  163.  
  164.  
  165.  /******************************************************************/
  166.  /*        SCREEN DRIVER                          */
  167.  /* Screen definition/input is repeated until F10 is pressed       */
  168.  /******************************************************************/
  169.  
  170.   scrhnd(STATUSON,KEY):-
  171.     settopline(STATUSON),
  172.     mkheader,
  173.     writescr,
  174.     field(FNAME,_,R,C,_),!,cursor(R,C),
  175.     chng_actfield(FNAME),
  176.     showcursor,
  177.     repeat,
  178.     writescr,
  179.     keypressed,/*Continuation until keypress means
  180.                  that time dependent
  181.              user functions can be updated*/
  182.     readkey(KEY),
  183.     scr(KEY),
  184.     showcursor,
  185.     endkey(KEY),!.
  186.  
  187.  /*****************************************************************/
  188.  /*             Find the next field              */
  189.  /*****************************************************************/
  190.  
  191. PREDICATES
  192.   /* The predicates should be called with:
  193.     ACTROW, ACTCOL, MAXROW, MAXCOL, NEWROW, NEWCOL   */
  194.   best_right(ROW,COL,ROW,COL,ROW,COL)
  195.   best_left(ROW,COL,ROW,COL,ROW,COL)
  196.   best_down(ROW,COL,ROW,COL,LEN,ROW,COL)
  197.   best_up(ROW,COL,ROW,COL,LEN,ROW,COL)
  198.   better_right(ROW,COL,ROW,COL,ROW,COL)
  199.   better_left(ROW,COL,ROW,COL,ROW,COL)
  200.   better_field(ROW,COL,ROW,COL,LEN,ROW,COL,LEN)
  201.   calcdist(ROW,COL,ROW,COL,LEN,LEN)
  202.   move_left
  203.   move_right
  204.   nextfield(ROW,COL)
  205.   gtfield(ROW,ROW,COL,COL)
  206.   prevfield(ROW,COL)
  207.     /***************************************************
  208.     * Modified 2/5/88 G.Wood
  209.     *   Added LEN to predicate chk_found. See changes to
  210.     *   chk_found clause.
  211.     ***************************************************/
  212.   /* chk_found(FNAME,ROW,COL,ROW,COL)  */
  213.   chk_found(FNAME,ROW,COL,ROW,COL,LEN)
  214.   setlastfield
  215.  
  216. CLAUSES
  217.   best_right(R0,C0,R1,C1,ROW,COL):-
  218.     field(_,_,R2,C2,_), C2>C0,
  219.     better_right(R0,C0,R1,C1,R2,C2),!,
  220.     best_right(R0,C0,R2,C2,ROW,COL).
  221.   best_right(_,_,R,C,R,C).
  222.  
  223.   better_right(R0,_,R1,_,R2,_):-abs(R2-R0)<abs(R1-R0),!.
  224.   better_right(R0,_,R1,C1,R2,C2):-abs(R2-R0)=abs(R1-R0),C2<C1.
  225.  
  226.   best_left(R0,C0,R1,C1,ROW,COL):-
  227.     field(_,_,R2,C2,_), C2<C0,
  228.     better_left(R0,C0,R1,C1,R2,C2),!,
  229.     best_left(R0,C0,R2,C2,ROW,COL).
  230.   best_left(_,_,R,C,R,C).
  231.  
  232.   better_left(R0,_,R1,_,R2,_):-abs(R2-R0)<abs(R1-R0),!.
  233.   better_left(R0,_,R1,C1,R2,C2):-abs(R2-R0)=abs(R1-R0),C2>C1.
  234.  
  235.   best_down(R0,C0,R1,C1,L1,ROW,COL):-
  236.     field(_,_,R2,C2,L2), R2>R0,
  237.     better_field(R0,C0,R1,C1,L1,R2,C2,L2),!,
  238.     best_down(R0,C0,R2,C2,L2,ROW,COL).
  239.   best_down(_,_,R,C,_,R,C).
  240.  
  241.   best_up(R0,C0,R1,C1,L1,ROW,COL):-
  242.     field(_,_,R2,C2,L2), R2<R0,
  243.     better_field(R0,C0,R1,C1,L1,R2,C2,L2),!,
  244.     best_up(R0,C0,R2,C2,L2,ROW,COL).
  245.   best_up(_,_,R,C,_,R,C).
  246.  
  247.   better_field(R0,C0,R1,C1,L1,R2,C2,L2):-
  248.     calcdist(R0,C0,R1,C1,L1,DIST1),
  249.     calcdist(R0,C0,R2,C2,L2,DIST2),
  250.     DIST2<DIST1.
  251.  
  252.   calcdist(R0,C0,R1,C1,L1,DIST):-
  253.     C11=C1+L1,
  254.     max(C0,C1,H1),
  255.     min(H1,C11,H2),
  256.     DIST=3*abs(R1-R0)+abs(H2-C0).
  257.  
  258.   move_left:-
  259.     not(typeerror),
  260.     actfield(FNAME),
  261.     field(FNAME,_,R,C,_),!,
  262.     best_left(R,C,-100,-100,ROW,COL),
  263.     field(F1,_,ROW,COL,_),
  264.     chng_actfield(F1),!,
  265.     cursor(ROW,COL).
  266.  
  267.   move_right:-
  268.     not(typeerror),
  269.     actfield(FNAME),
  270.     field(FNAME,_,R,C,_),!,
  271.     best_right(R,C,-100,-100,ROW,COL),
  272.     field(F1,_,ROW,COL,_),
  273.     chng_actfield(F1),!,
  274.     cursor(ROW,COL).
  275.      /*************************************************************
  276.       * Modified 2/5/88 G. Wood
  277.       *   Changed chk_found clause in prevfield to include LEN.
  278.       *   Changed existing chk_found clauses to incorporate the
  279.       *      additional variable position.
  280.       *   Added new chk_found clause (second position) to check
  281.       *      if current cursor position is in a defined field
  282.       *   These changes will allow use of back-tab when anywhere
  283.       *      in a field to return to first character of field then
  284.       *      proceed to "back up" one field at a time.
  285.       ************************************************************/
  286.   prevfield(_,_):-typeerror,!,fail.
  287.   prevfield(R,C):-
  288.         field(FNAME,_,ROW,COL,LEN),
  289.         chk_found(FNAME,R,C,ROW,COL,LEN),!,
  290.         actfield(F1),
  291.         field(F1,_,RR,CC,_),!,
  292.         cursor(RR,CC).
  293.  
  294.   chk_found(_,R,C,R,C,_):-!.
  295.   chk_found(FNAME,R,C,R,COL,LEN):-
  296.         C > COL,
  297.         C < COL + LEN,
  298.         chng_actfield(FNAME).
  299.   chk_found(FNAME,_,_,_,_,_):-chng_actfield(FNAME),fail.
  300.  
  301.  /*****************************************************************
  302.   * Modified 2/5/88 - G.Wood
  303.   *   Commented out nextfield(_,_) and replaced with indicated clause.
  304.   *   This will allow the scr(tab) clause to "wrap around" from last
  305.   *   field to first field, and changes to scr(right) to allow filling
  306.   *   last field and "wrap around" to first field.
  307.   *******************************************************************/
  308.  
  309.  
  310.   nextfield(_,_):-typeerror,!,fail.
  311.   nextfield(R,C):-
  312.     field(FNAME,_,ROW,COL,_),gtfield(ROW,R,COL,C),
  313.     chng_actfield(FNAME),!,
  314.     cursor(ROW,COL).
  315.  /*  nextfield(_,_).  */
  316.  
  317.   nextfield(_,_):-
  318.         scr(home).
  319.  
  320.   gtfield(R1,R2,_,_):-R1>R2,!.
  321.   gtfield(R,R,C1,C2):-C1>C2.
  322.  
  323.   setlastfield:-
  324.     field(FNAME,_,_,_,_),
  325.     chng_actfield(FNAME),
  326.     fail.
  327.   setlastfield.
  328.  
  329.  
  330.  /*****************************************************************/
  331.  /*        scr                             */
  332.  /*****************************************************************/
  333.  
  334.   /* Insert a new character in a field */
  335.   scr(char(T)):-actfield(FNAME),
  336.         not(noinput(FNAME)),
  337.         cursor(_,C),
  338.         field(FNAME,_,ROW,COL,LEN),!,
  339.         POS=C-COL,
  340.         oldstr(FNAME,STR),
  341.         lin(char(T),POS,STR,STR1),
  342.         trunc_(LEN,STR1,STR2),
  343.         ass_val(FNAME,STR2),
  344.         field_str(ROW,COL,LEN,STR2),
  345.         scr(right).
  346.         
  347.  
  348.   /* Delete character under cursor */
  349.   scr(del):-    actfield(FNAME),
  350.         not(noinput(FNAME)),
  351.         cursor(_,C),
  352.         field(FNAME,_,ROW,COL,LEN),!,
  353.         POS=C-COL,
  354.         oldstr(FNAME,STR),
  355.         lin(del,POS,STR,STR1),
  356.         ass_val(FNAME,STR1),
  357.         field_str(ROW,COL,LEN,STR1).
  358.         
  359.   /* Delete character before cursor and move cursor to the left */
  360.   scr(bdel):-    actfield(FNAME),
  361.         not(noinput(FNAME)),
  362.         cursor(_,C),
  363.         field(FNAME,_,ROW,COL,LEN),!,
  364.         POS=C-COL-1,
  365.         oldstr(FNAME,STR),
  366.         lin(del,POS,STR,STR1),
  367.         ass_val(FNAME,STR1),
  368.         field_str(ROW,COL,LEN,STR1),
  369.         scr(left).
  370.  
  371.  /*If there is an action - do it. Otherwise, go to next field*/
  372.   scr(cr):-
  373.     actfield(FNAME),
  374.     field_action(FNAME),
  375.     cursor(RR,CC),cursor(RR,CC),!.
  376.   scr(cr):-cursor(RR,CC),cursor(RR,CC),scr(tab).
  377.  
  378.  
  379.   /* Change between insertmode and overwritemode */
  380.   scr(ins):-changemode,showoverwrite.
  381.  
  382.   /* escape */
  383.   scr( esc ).
  384.  
  385.   /* F10: end of definition */
  386.   scr( fkey(10) ):-not(typeerror).
  387.   /*************************************************************
  388.    * Modified 2/5/88 G.Wood
  389.    * Added clauses to scr for fkeys 1 thru 9, and new symbolic
  390.    *       key 'plus'. Allows these keys to now be recognized and
  391.    *       processed
  392.    ************************************************************/
  393.   scr( fkey(1) ):-not(typeerror).
  394.   scr( fkey(2) ):-not(typeerror).
  395.   scr( fkey(3) ):-not(typeerror).
  396.   scr( fkey(4) ):-not(typeerror).
  397.   scr( fkey(5) ):-not(typeerror).
  398.   scr( fkey(6) ):-not(typeerror).
  399.   scr( fkey(7) ):-not(typeerror).
  400.   scr( fkey(8) ):-not(typeerror).
  401.   scr( fkey(9) ):-not(typeerror).
  402.   scr( plus )   :-not(typeerror).
  403.  
  404.   scr(right):-
  405.     actfield(FNAME),
  406.     not(noinput(FNAME)),
  407.     field(FNAME,_,_,C,L),
  408.     cursor(ROW,COL), COL<C+L-1,!,
  409.     COL1=COL+1,
  410.     cursor(ROW,COL1).
  411.  /*****************************************************************
  412.   * Modified 2/5/88 - G.Wood
  413.   *   Commented out scr(right):-move_right and replaced with
  414.   *   indicated clause to allow an auto-skip from active
  415.   *   field when full to next field, next in the sense of left to
  416.   *   right, top to bottom.
  417.   *   See changes to nextfield clause which will cause "wrap around"
  418.   *   to first field when last field is filled
  419.   ****************************************************************/
  420.  
  421.  /*  scr(right):-move_right. */
  422.     scr(right):-
  423.        cursor(R,C),!,
  424.        nextfield(R,C).
  425.  
  426.  
  427.   scr(ctrlright):-
  428.     actfield(FNAME),
  429.     not(noinput(FNAME)),
  430.     field(FNAME,_,_,C,L),
  431.     cursor(ROW,COL),
  432.     COL1=COL+5, COL1<C+L-1,!,
  433.     cursor(ROW,COL1).
  434.  
  435.   scr(ctrlright):-move_right.
  436.  
  437.   scr(left):-
  438.     actfield(FNAME), field(FNAME,_,_,C,_),
  439.     cursor(ROW,COL),
  440.     COL>C,!,
  441.     COL1=COL-1,
  442.     cursor(ROW,COL1).
  443.  
  444.   scr(left):-move_left.
  445.  
  446.   scr(ctrlleft):-
  447.     actfield(FNAME), field(FNAME,_,_,C,_),
  448.     cursor(ROW,COL),
  449.     COL1=COL-5, COL1>C,!,
  450.     cursor(ROW,COL1).
  451.  
  452.   scr(ctrlleft):-move_left.
  453.  
  454.   scr(tab):-
  455.     cursor(R,C),
  456.     nextfield(R,C).
  457.  
  458.   scr(btab):-
  459.     cursor(R,C),
  460.     prevfield(R,C).
  461.  
  462.   scr(up):-
  463.     not(typeerror),
  464.     cursor(R,C),
  465.     best_up(R,C,-100,-100,1,ROW,COL),
  466.     field(F1,_,ROW,COL,_),
  467.     chng_actfield(F1),!,
  468.     cursor(ROW,COL).
  469.  
  470.   scr(down):-
  471.     not(typeerror),
  472.     cursor(R,C),
  473.     best_down(R,C,100,100,1,ROW,COL),
  474.     field(F1,_,ROW,COL,_),
  475.     chng_actfield(F1),!,
  476.     cursor(ROW,COL).
  477.  
  478.   scr(home):-
  479.     not(typeerror),
  480.     field(F1,_,ROW,COL,_),
  481.     chng_actfield(F1),!,
  482.     cursor(ROW,COL).
  483.  
  484.   scr(end):-
  485.     not(typeerror),
  486.     setlastfield,
  487.     actfield(FNAME),
  488.     field(FNAME,_,ROW,COL,_),!,
  489.     cursor(ROW,COL).
  490.  
  491. /* scr(fkey(1)):-help.  If helpsystem is used. */
  492.  
  493.  
  494.  /*****************************************************************/
  495.  /*    Predicates maintaining the top messages line              */
  496.  /*****************************************************************/
  497.  
  498.   mkheader:-notopline,!.
  499.   mkheader:-
  500.       shiftwindow(OLD),
  501.     gotowindow(85),
  502.     field_str(0,0,30,"ROW:      COL:"),
  503.     gotowindow(OLD).
  504.  
  505. PREDICATES
  506.   get_overwritestatus(STRING)
  507.   show_str(COL,LEN,STRING)
  508.   showfield(ROW,COL)
  509.  
  510. CLAUSES
  511.   get_overwritestatus(insert):-insmode,!.
  512.   get_overwritestatus(overwrite).
  513.  
  514.   show_str(C,L,STR):-
  515.     windowsize(_,COLS),
  516.     C<COLS,!,
  517.     MAXL=COLS-C,
  518.     min(L,MAXL,LL),
  519.     field_str(0,C,LL,STR).
  520.   show_str(_,_,_).
  521.  
  522.   showoverwrite:-notopline,!.
  523.   showoverwrite:-
  524.     shiftwindow(OLD),
  525.     gotowindow(85),
  526.     get_overwritestatus(OV),
  527.     show_str(20,9,OV),
  528.     gotowindow(OLD).
  529.  
  530.   showfield(_,_):-keypressed,!.
  531.   showfield(R,C):-
  532.     field(FNAME,TYP,ROW,COL,LEN),
  533.     ROW=R, COL<=C, C<COL+LEN,
  534.     types(_,TYP,TYPE),!,
  535.     show_str(30,8,TYPE),
  536.     STR=FNAME, show_str(38,42,STR).
  537.   showfield(_,_):-keypressed,!.
  538.   showfield(R,C):-
  539.     txtfield(ROW,COL,LEN,TXT),
  540.     ROW=R, COL<=C, C<=COL+LEN,!,
  541.     show_str(30,1,"\""),
  542.     show_str(31,49,TXT).
  543.   showfield(_,_):-show_str(30,50,"").
  544.  
  545.   showcursor:-keypressed,!.
  546.   showcursor:-notopline,!.
  547.   showcursor:-
  548.     shiftwindow(OLD),
  549.     cursor(R,C),
  550.     str_int(RSTR,R), str_int(CSTR,C), 
  551.     gotowindow(85),
  552.     show_str(4,4,RSTR), show_str(14,4,CSTR),
  553.     showfield(R,C),
  554.     gotowindow(OLD),
  555.     cursor(R,C).
  556.  
  557.  
  558.  /*****************************************************************/
  559.  /*    update all fields on the screen                      */
  560.  /*****************************************************************/
  561.  
  562.   writescr:-
  563.     field(FNAME,_,ROW,COL,LEN),
  564.     field_attr(ROW,COL,LEN,112),
  565.     field_value(FNAME,STR),
  566.     field_str(ROW,COL,LEN,STR),
  567.     keypressed,!.
  568.   writescr:-
  569.     txtfield(ROW,COL,LEN,STR),
  570.     field_str(ROW,COL,LEN,STR),
  571.     keypressed,!.
  572.   writescr.
  573.  
  574.  
  575.  /*****************************************************************/
  576.  /*        Shift screen                         */
  577.  /*         Can be used if needed                      */
  578.  /*****************************************************************/
  579. /*
  580. PREDICATES
  581.   shiftscreen(SYMBOL)
  582.  
  583. CLAUSES
  584.   shiftscreen(_):-retract(field(_,_,_,_,_)),fail.
  585.   shiftscreen(_):-retract(txtfield(_,_,_,_)),fail.
  586.   shiftscreen(_):-retract(windowsize(_,_)),fail.
  587.   shiftscreen(NAME):-screen(NAME,TERM),assert(TERM),fail.
  588.   shiftscreen(_).
  589. */
  590.  
  591.