home *** CD-ROM | disk | FTP | other *** search
/ Shareware Overload / ShartewareOverload.cdr / database / ronheb.zip / RONHEB.PRG < prev    next >
Text File  |  1988-11-11  |  6KB  |  305 lines
  1.  
  2. function initheb
  3. parameters rhp1
  4.  
  5. * -- public: rhcount initiated to 0                                rhcount
  6. * --         asci-string ('...ABC...hebrew set....')               rhtr
  7. * --         current rhebvld variable                              rhcv
  8. * --         hebrew-read simu-updated() function variable          rhupdth
  9.  
  10. if pcount()=0
  11.    rhp1=50
  12. else
  13.    if type('p1')!="N"
  14.       rhp1=50
  15.    endif
  16. endif
  17. public rhcount,rhtr,rhcv,rhupdth,prg,rhcolor,rhver
  18. set confirm on 
  19. set scoreboard off
  20. public rhrow[rhp1],rhcol[rhp1],rhvar[rhp1],rhvld[rhp1],rhsk[71]
  21. rhcount=0
  22. rhver="RONHEB/S87 V1.1"
  23. rhtr=",()*+Ü-ò.0123456789:ô<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_;ÖÉüéùïÆëÅçîèûÄìö/ÿâÇàä'æêå"
  24. rhcv=""
  25. rhcolor=setcolor()
  26. afill(rhsk,"")
  27. prg=""
  28. rhupdth=.f.
  29. return(.t.)
  30.  
  31.  
  32.  
  33.  
  34.  
  35.  
  36.  
  37. function rhebvld
  38.  
  39.  
  40. private hrow,hcol,vrhcount,irhcount,irh,yrh,tmprvar,ovar,rvar,lenvar,lrh
  41.  
  42. irhcount=substr(readvar(),4,2)
  43. vrhcount=&irhcount
  44. if !(rhn&irhcount=="")
  45.    rhn&irhcount=""
  46.    return(.t.)
  47. endif
  48.  
  49. hrow=rhrow[vrhcount]
  50. hcol=rhcol[vrhcount]
  51. rvar=rhvar[vrhcount]
  52. rhcv=upper(rvar)
  53. ovar=&rvar
  54. rhtmp=ovar
  55. lenvar=len(rhtmp)
  56.  
  57. ins=.f.
  58. rhcolor=setcolor()
  59. rhcolour()
  60. @ hrow,hcol say ""
  61. irh=1
  62. do while .t.
  63.    
  64.    inkey(0)
  65.    lrh=lastkey()
  66.    do case 
  67.       case lrh>31
  68.          if irh>lenvar
  69.             ?? chr(7)
  70.             loop
  71.          endif
  72.          tmprvar=htrans(lrh)
  73.          if .not.ins
  74.             rhtmp=substr(rhtmp,1,lenvar-irh)+tmprvar+substr(rhtmp,lenvar-irh+2,irh-1)
  75.  
  76.             * htrans will transform an inkey() value into
  77.             * corresponding hebrew set charecter by substr a charecter-list string.
  78.  
  79.             * if .not. ins then say rhtmp[i] and cursor only. else say by arraysay 
  80.             * after ains with pos=i+1
  81.  
  82.             @ hrow,hcol-irh+1 say tmprvar
  83.             irh=irh+1
  84.             @ hrow,hcol-irh+1 say ""
  85.             loop
  86.          else
  87.             rhtmp=substr(rhtmp,2,lenvar-irh)+tmprvar+substr(rhtmp,lenvar-irh+2,irh-1)
  88.             @ hrow,hcol-lenvar+1 say substr(rhtmp,1,lenvar-irh+1)
  89.             irh=irh+1
  90.             @ hrow,hcol-irh+1 say ""
  91.             loop
  92.          endif
  93.    
  94.       case lrh=4  && rt arrow
  95.          irh=iif(irh>1,irh-1,1)
  96.          * say cursor only
  97.          @ hrow,hcol-irh+1 say ""
  98.          loop
  99.  
  100.       case lrh=19 && lt arrow
  101.          irh=iif(irh<lenvar,irh+1,lenvar)
  102.          @ hrow,hcol-irh+1 say ""
  103.          loop
  104.    
  105.       case lrh=22 && insert
  106.          ins=iif(ins,.f.,.t.)
  107.          loop
  108.  
  109.       case lrh=7  && del
  110.          rhtmp=" "+substr(rhtmp,1,lenvar-irh)+substr(rhtmp,lenvar-irh+2,irh-1)
  111.          @ hrow,hcol-lenvar+1 say rhtmp
  112.          @ hrow,hcol-irh+1 say ""
  113.          loop
  114.  
  115.       case lrh=8
  116.          if irh>1
  117.             irh=irh-1
  118.             rhtmp=substr(rhtmp,1,lenvar-irh)+" "+;
  119.             substr(rhtmp,lenvar-irh+2,irh-1)
  120.             @ hrow,hcol-lenvar+1 say rhtmp
  121.             @ hrow,hcol-irh+1 say ""
  122.          endif
  123.          loop
  124.       case lrh=1
  125.          loop
  126.       case lrh=2
  127.          loop
  128.       case lrh=26
  129.          loop
  130.       case lrh=29
  131.          loop
  132.       case lrh=30
  133.          loop
  134.       case lrh=31
  135.          loop
  136.  
  137.       case lrh=27
  138.          setcolor(rhcolor)
  139.          rhcv=""
  140.          rhn&irhcount=substr(rhtmp,lenvar,1)
  141.          * keyboard the last chr
  142.          &rvar=ovar
  143.          hkboard("chr(27)")
  144.          return(.F.)
  145.  
  146.       otherwise
  147.          * check for pre-defined hot-keys
  148.          if !(rhsk[lrh+40]=="")
  149.             dorhsk=rhsk[lrh+40]
  150.             setcolor(rhcolor)
  151.             &rvar=rhtmp
  152.             do &dorhsk with prg,0,rhcv
  153.             rhcolor = setcolor()
  154.             rhcolour()
  155.             @ hrow,hcol say ""
  156.             irh=1
  157.             ins=.f.
  158.             loop
  159.          else
  160.           if lrh != 13
  161.             loop
  162.           endif
  163.          endif
  164.          
  165.    endcase
  166.  
  167.    &rvar=rhtmp
  168.  
  169.    * check validity of input
  170.    setcolor(rhcolor)
  171.    rvld=rhvld[vrhcount]
  172.    rhcolor = setcolor()
  173.    rhcolour()
  174.    if .not.&rvld
  175.       &rvar=ovar
  176.       @ hrow,hcol say ""
  177.       irh=1
  178.       ins=.f.
  179.       loop
  180.    endif
  181.  
  182.    setcolor(rhcolor)
  183.  
  184.    if ovar!=rhtmp
  185.       * update inicator
  186.       rhupdth=.t.
  187.    endif
  188.  
  189.    rhcv=""
  190.    rhn&irhcount=substr(rhtmp,lenvar,1)
  191.  
  192.    * keyboard the last chr 
  193.    lchar=str(lrh)
  194.    hkboard("chr(&lchar)")
  195.    return(.F.)
  196.  
  197. enddo
  198.  
  199.  
  200.  
  201.  
  202.  
  203.  
  204. function readh
  205. * will initiate a read.
  206. * will release all redundant hebrew vars.
  207.  
  208. rhupdth=.f.
  209. read
  210. release rvar
  211. release rvld
  212. release all like rhn*
  213. rhcv=""
  214. rhcount=0
  215. return(.t.)
  216.  
  217.  
  218.  
  219.  
  220.  
  221.  
  222. function htrans
  223. parameters asci
  224.  
  225. * rhtr=",()*+Ü-ò.0123456789:ô<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_;"+
  226. *     "ÖÉüéùïÆëÅçîèûÄìö/ÿâÇàä'æêå"
  227.  
  228. return(iif((asci<123).and.(asci>38),substr(rhtr,asci-38,1),chr(asci)))
  229.  
  230.  
  231.  
  232.  
  233.  
  234. function hkboard
  235. parameters kbdchar
  236.  
  237. * -- flush keyboard into a buffer and add a control character upfront.
  238. * -- re-keyboard it all
  239.  
  240. private cinkbfr,keybfr
  241. keybfr=kbdchar
  242. do while inkey()>0
  243.    cinkbfr=str(lastkey())
  244.    keybfr=keybfr+"+chr(&cinkbfr)"
  245. enddo
  246. keyboard &keybfr
  247.  
  248. return(.t.)
  249.  
  250.  
  251.  
  252.  
  253.  
  254.  
  255. function readhvar
  256.  
  257. * -- to return current hebrew-read variable
  258.  
  259. if rhcv==""
  260.    return(readvar())
  261. else
  262.    return(rhcv)
  263. endif
  264.  
  265.  
  266.  
  267. function hebfield
  268. return(iif(rhcv=="",.f.,.t.))
  269.  
  270.  
  271.  
  272. function hupdated
  273.  
  274. * -- returns .t. if there was an update in the last read
  275.  
  276. return((updated()).or.(rhupdth))
  277.  
  278.  
  279.  
  280.  
  281.  
  282.  
  283.  
  284. function rhsetk
  285. parameters keynumb,keycont
  286. rhsk[keynumb+40]=keycont
  287. set key keynumb to &keycont
  288. return(.t.)
  289.  
  290.  
  291.  
  292.  
  293.  
  294. function rhcolour
  295. private tcolor,ncolor,ecolor
  296. tcolor=rhcolor
  297. ncolor=substr(tcolor,1,at(",",tcolor)-1)
  298. tcolor=substr(tcolor,len(ncolor)+2,len(tcolor))
  299. ecolor=substr(tcolor,1,at(",",tcolor)-1)
  300. setcolor(ecolor+","+ecolor+","+tcolor)
  301. return(.t.)
  302.  
  303.  
  304.  
  305.