home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / xbase / library / dbase / duflp / sca.prg < prev    next >
Text File  |  1992-06-25  |  16KB  |  403 lines
  1. *-------------------------------------------------------------------------------
  2. *-- Program...: SCA.PRG
  3. *-- Programmer: Ken Mayer (KENMAYER)
  4. *-- Date......: 06/25/1992
  5. *-- Notes.....: This file contains the SCA Date handling routines, as well as a
  6. *--             copy of the roman numeral to arabic and vice-versa functions,
  7. *--             that are contained in CONVERT.PRG. This is due to the fact
  8. *--             that only two library files may be open at one time. See
  9. *--             the file README.TXT for more details on the use of this library
  10. *--             file.
  11. *-------------------------------------------------------------------------------
  12.  
  13. PROCEDURE SCA_Real
  14. *-------------------------------------------------------------------------------
  15. *-- Programmer..: Ken Mayer (Hirsch von Henford in the SCA) (KENMAYER)
  16. *-- Date........: 07/29/1991
  17. *-- Notes.......: This procedure was designed to handle data entered into
  18. *--               the Order of Precedence of the Principality of the Mists.
  19. *--               The problem is, my usual sources of data give only SCA
  20. *--               dates, and in order to sort properly, I need real dates.
  21. *--               This procedure will handle it, and goes hand-in-hand with
  22. *--               the function Real_SCA, to translate real dates to SCA
  23. *--               dates ... This procedure assumes that you have set the
  24. *--               F1 Key (see Example below). If you use a different F key,
  25. *--               you will want to modify the ON KEY LABEL commands ...
  26. *-- Written for.: dBASE IV, 1.1
  27. *-- Rev. History: 07/23/1991 - original procedure.
  28. *--               07/29/1991  -- modified it to stuff a character directly into
  29. *--               a date field (was having to do a CTOD in the program),
  30. *--               and added use of ESC to escape out, instead of killing
  31. *--               the procedure and the program calling it ...
  32. *-- Calls.......: CENTER               Procedure in PROC.PRG
  33. *--               SHADOW               Procedure in PROC.PRG
  34. *--               ARABIC()             Function in PROC.PRG
  35. *-- Called by...: Any
  36. *-- Usage.......: do SCA_Real
  37. *-- Example.....: on key label f1 do sca_real
  38. *--               store {} to t_date   && initialize as a date
  39. *--                                    && or you could STORE datefield to t_date
  40. *--                                    && if you have a date field ...
  41. *--               clear
  42. *--               @5,10 say "Enter a date:" get t_date;
  43. *--                  message "Press <F1> to convert from SCA date to real date"
  44. *--               read
  45. *--               on key label f1  && clear out that command ...
  46. *-- Returns.....: real date, forced into field ...
  47. *-- Parameters..: None
  48. *-------------------------------------------------------------------------------
  49.     
  50.     private cEscape,cExact,cYear,cMonth,cDay,nYearlen,nCount,nYear,nMonth
  51.     private nDay,cDate
  52.     
  53.     cEscape = set("ESCAPE")
  54.     set escape off            && so we can handle the Escape Key
  55.     cExact = set("EXACT")
  56.     set exact on              && VERY important ...
  57.     on key label F1 ?? chr(7) && make it beep, rather than call this procedure 
  58.                               && again, which causes wierdnesses ...
  59.     *-- first let's popup a window to ask for the information ...
  60.     
  61.     save screen to sDate
  62.     define window wDate from 8,20 to 15,60 color rg+/gb,n/g,rg+/gb
  63.     do shadow with 8,20,15,60
  64.     activate window wDate
  65.     
  66.     *-- set the memvars ...
  67.     cYear  = space(8)
  68.     cMonth = space(3)
  69.     cDay   = space(2)
  70.     
  71.     do center with 0,40,"","Enter SCA Date below:"
  72.     do while .t.
  73.         
  74.         @2,14 say "Month: " get cMonth ;
  75.             picture "@M JAN,FEB,MAR,APR,MAY,JUN,JUL,AUG,SEP,OCT,NOV,DEC";
  76.             message "Enter first letter of month, <Space> to scroll through, "+;
  77.                 "<Enter> to choose" color rg+/gb,n/g
  78.         @3,14 say "  Day: " get cDay picture "99";
  79.             message "Enter 2 digits for day of the month, if blank will assume 15";
  80.                 color rg+/gb,n/g
  81.         @4,14 say " Year: " get cYear picture "!!!!!!!!" ;
  82.             message "Enter year in AS roman numeral format";
  83.             valid required len(trim(cYear)) > 0;
  84.             error chr(7)+"This is no good without a year ..." color rg+/gb,n/g
  85.     
  86.         read
  87.     
  88.         if lastkey() = 27                && if user wants out by pressing <Esc>
  89.             deactivate window wDate
  90.             release window wDate
  91.             restore screen from sDate
  92.             release screen sDate
  93.             set escape &cEscape
  94.             set exact &cExact
  95.             on key label F1 do SCA_Real   && reset it ...
  96.             return
  97.         endif
  98.         
  99.         if lastkey() < 0   && function key F1 through Shift F9 was pressed
  100.             ?? chr(7)       && beep at user
  101.             loop            && don't let 'em get away with that -- try again
  102.         endif
  103.         
  104.         *-- check for valid roman numerals
  105.         cYear = trim(cYear)    && trim it
  106.         nYearLen = len(cYear)  && get length
  107.         nCount = 0            
  108.         do while nCount < nYearLen  && loop through length of year
  109.             nCount = nCount + 1      && increment
  110.             if .not. substr(cYear,nCount,1) $ "IVXLC" && if it's not here
  111.                 do center with 5,40,"rg+/r","** ERROR -- Invalid Year **"
  112.                 lError = .t.          && set error flag
  113.                 exit                  && exit internal loop
  114.             else
  115.                 lError = .f.          && make sure this is false
  116.             endif
  117.         enddo     && end of internal loop
  118.         if lError && if error,
  119.             loop   && go back ...
  120.         endif
  121.         
  122.         @5,0 clear   && clear out any error message ...
  123.         do center with 5,40,"rg+/r","Converting Date ..."
  124.         
  125.         *-- First (and most important) is conversion of the year
  126.         nYear = Arabic(cYear)
  127.         
  128.         *-- AS Years start at May ... if the month for a specific year is
  129.         *-- Jan through April it's part of the next "real" year ...
  130.         if cMonth = "JAN" .or. cMonth = "FEB" .or. cMonth = "MAR" .or.;
  131.                                        cMonth = "APR"
  132.             nYear = nYear + 1
  133.         endif
  134.         
  135.         nYear = nYear + 65  && SCA dates start at 66 ...
  136.         if nYear > 99       && this thing doesn't handle turn of the century
  137.             @5,0 clear
  138.             do center with 5,40,"rg+/r","No dates past XXXIV, please"
  139.             loop
  140.         endif
  141.         
  142.         *-- set numeric value of month ...
  143.         do case
  144.             case cMonth = "JAN"
  145.                 nMonth = 1
  146.             case cMonth = "FEB"
  147.                 nMonth = 2
  148.             case cMonth = "MAR"
  149.                 nMonth = 3
  150.             case cMonth = "APR"
  151.                 nMonth = 4
  152.             case cMonth = "MAY"
  153.                 nMonth = 5
  154.             case cMonth = "JUN"
  155.                 nMonth = 6
  156.             case cMonth = "JUL"
  157.                 nMonth = 7
  158.             case cMonth = "AUG"
  159.                 nMonth = 8
  160.             case cMonth = "SEP"
  161.                 nMonth = 9
  162.             case cMonth = "OCT"
  163.                 nMonth = 10
  164.             case cMonth = "NOV"
  165.                 nMonth = 11
  166.             case cMonth = "DEC"
  167.                 nMonth = 12
  168.         endcase
  169.         
  170.         *-- if the day field is empty, assume the middle of the month, so we
  171.         *-- have SOMETHING to go by ...
  172.         if len(alltrim(cDay)) = 0
  173.             nDay = 15
  174.         else
  175.             nDay = val(cDay)
  176.         endif
  177.         
  178.         *-- Check for valid day of the month ...
  179.         if nDay > 29 .and. nMonth = 2 .or. (nDay = 31 .and. (nMonth = 4 .or.;
  180.                                  nMonth = 6 .or. nMonth = 9 .or. nMonth = 11))
  181.             do center with 5,40,"rg+/r",chr(7)+"INVALID DATE -- Try again ..."
  182.             loop
  183.         endif
  184.         
  185.         exit                        && out of loop -- if here, we're done
  186.         
  187.     enddo                          && end of loop
  188.  
  189.     *-- Convert it
  190.     cDate = transform(nMonth,"@L 99")+transform(nDay,"@L 99")+;
  191.               transform(nYear,"@L 99")
  192.     
  193.     *-- force this 'character' date into the date field on the screen ...
  194.     keyboard cDate clear           && put it into the field, and clear out
  195.                                    && keyboard buffer first ...
  196.  
  197.     *-- deal with cleanup ...
  198.     deac wind wDate
  199.     release wind wDate
  200.     restore screen from sDate
  201.     release screen sDate
  202.     set escape &cEscape
  203.     set exact &cExact
  204.     on key label F1 do SCA_Real  && reset for user
  205.     
  206. RETURN
  207. *-- EoP: SCA_Real
  208.  
  209. FUNCTION SCA2Real
  210. *-------------------------------------------------------------------------------
  211. *-- Programmer..: Jay Parsons (JPARSONS)
  212. *-- Date........: 04/22/1992
  213. *-- Notes.......: Jay figured out a short version of SCA_Real above, which
  214. *--               does not use screen input/screen display. This can be used
  215. *--               directly as a function.
  216. *-- Written for.: dBASE IV, 1.5
  217. *-- Rev. History: None
  218. *-- Calls.......: ALLTRIM()            Function in PROC.PRG
  219. *--               ARABIC()             Function in CONVERT.PRG (and below)
  220. *-- Called by...: Any
  221. *-- Usage.......: SCA2Real(<cDay>,<cMonth>,<cYear>)
  222. *-- Example.....: ?SCA2Real("12","JAN","XXVI")
  223. *-- Returns.....: dBASE Date (from example above: 01/12/92)
  224. *-- Parameters..: cDay   = Character day of month
  225. *--               cMonth = Character day of month
  226. *--               cYear  = Roman Numeric version of year (SCA dates)
  227. *-------------------------------------------------------------------------------
  228.  
  229.     parameters cDay, cMonth, cYear
  230.     private nMonth, nDay, nYear
  231.     
  232.     nMonth = at(upper(left(cMonth,3)),"    JAN FEB MAR APR MAY JUN";
  233.               +" JUL AUG SEP OCT NOV DEC") /4
  234.     nDay = iif(""=alltrim(cDay),15,val(cDay))
  235.     nYear = arabic(cYear)+1965+iif(nMonth < 5,1,0)
  236.     
  237. RETURN ctod(right(str(nMonth+100),2)+"/";
  238.          +right(str(nDay+100),2)+"/"+str(nYear))
  239. *-- EoF: SCA2Real()
  240.  
  241. FUNCTION Real_SCA
  242. *-------------------------------------------------------------------------------
  243. *-- Programmer..: Ken Mayer (Hirsch von Henford in the SCA) (KENMAYER)
  244. *-- Date........: 07/23/1991
  245. *-- Notes.......: This procedure was designed to handle data entered into
  246. *--               the Order of Precedence of the Principality of the Mists.
  247. *--               For the purpose of printing the Order of Precedence, it 
  248. *--               is necessary to convert real dates to SCA dates. I needed
  249. *--               to store the data as real dates, but I want it to print with
  250. *--               SCA dates ...
  251. *-- Written for.: dBASE IV, 1.1
  252. *-- Rev. History: None
  253. *-- Calls.......: ROMAN()              Function in PROC.PRG
  254. *-- Called by...: Any
  255. *-- Usage.......: Real_SCA(<dDate>)
  256. *-- Example.....: @nLine,25 say Real_SCA(CA)  && print SCA date for Corolla 
  257. *--                                           &&   Aulica
  258. *-- Returns.....: SCA Date based on dDate
  259. *-- Parameters..: dDate = date to be converted
  260. *-------------------------------------------------------------------------------
  261.  
  262.     PARAMETERS dDate   && a real date, to be converted to an SCA date ...
  263.     private nYear,nMonth,cMonth,cDay
  264.     
  265.     nYear  = year(dDate) - 1900        && remove the century
  266.     nMonth = month(dDate)
  267.     cMonth = substr(cmonth(dDate),1,3) && grab only first three characters
  268.     cDay   = ltrim(str(day(dDate)))    && convert day to character
  269.     
  270.     *-- First (and most important) is conversion of the year
  271.     *-- this is set to the turn of the century ... (AS XXXV)
  272.     *-- AS Years start at May ... if the month for a specific year is
  273.     *-- Jan through April it's part of the previous SCA year 
  274.     *-- (April '67 = April AS I, not II)
  275.      
  276.     if nMonth < 5
  277.         nYear = nYear - 1
  278.     endif
  279.     
  280.     nYear = nYear - 65   && SCA dates start at 66
  281.     cYear = Roman(nYear)
  282.  
  283. RETURN cMonth+" "+cDay+", "+"AS "+cYear
  284. *-- EoF: Real_SCA()
  285.  
  286. *-------------------------------------------------------------------------------
  287. *-- These two functions were included in this library file, so that you (or I)
  288. *-- do not have to figure a way to combine the functions below from CONVERT.PRG
  289. *-- and this file into one library file.
  290. *-------------------------------------------------------------------------------
  291.  
  292. FUNCTION Roman
  293. *-------------------------------------------------------------------------------
  294. *-- Programmer..: Nick Carlin
  295. *-- Date........: 04/26/1992
  296. *-- Notes.......: A function designed to return a Roman Numeral based on
  297. *--               an Arabic Numeral input ...
  298. *-- Written for.: dBASE III+
  299. *-- Rev. History: 04/13/1988 - original function.
  300. *--               07/25/1991 - Ken Mayer - 1) modified for dBASE IV, 1.1,
  301. *--                             2) updated to a function, and 3) the procedure
  302. *--                             GetRoman was done away with (combined into the
  303. *--                             function).
  304. *--               04/26/1992 - Jay Parsons - shortened (seriously ...)
  305. *-- Calls.......: None
  306. *-- Called by...: Any
  307. *-- Usage.......: Roman(<nArabic>)
  308. *-- Example.....: ? Roman(32)
  309. *-- Returns.....: Roman Numeral (character string) equivalent of Arabic numeral
  310. *--               passed to it. In example:  XXXII
  311. *-- Parameters..: nArabic = Arabic number to be converted to Roman
  312. *-------------------------------------------------------------------------------
  313.  
  314.    parameters nArabic
  315.    private cLetrs,nCount,nValue,cRoman,cGroup,nMod
  316.     
  317.    cLetrs ="MWYCDMXLCIVX"      && Roman digits
  318.    cRoman = ""                 && this is the returned value
  319.    nCount = 0                  && init counter
  320.    do while nCount < 4         && loop four times, once for thousands, once
  321.                                && for each of hundreds, tens and singles
  322.       nValue = mod( int( nArabic /  10 ^ ( 3 - nCount ) ), 10 )
  323.       cGroup = substr( cLetrs, nCount * 3 + 1, 3 )
  324.       nMod = mod( nValue, 5 )
  325.       if nMod = 4
  326.          if nValue = 9                 && 9
  327.             cRoman = cRoman + left( cGroup, 1 ) + right( cGroup, 1 )
  328.          else                          && 4
  329.             cRoman = cRoman + left( cGroup, 2 )
  330.          endif
  331.       else
  332.          if nValue > 4                 && 5 - 8
  333.             cRoman = cRoman + substr( cGroup, 2, 1 )
  334.          endif
  335.          if nMod > 0                   && 1 - 3 and 6 - 8
  336.             cRoman = cRoman + replicate( left( cGroup, 1 ), nMod )
  337.          endif
  338.       endif
  339.       nCount = nCount + 1
  340.    enddo  && while nCounter < 4
  341.     
  342. RETURN cRoman
  343. *-- EoF: Roman()
  344.  
  345. FUNCTION Arabic
  346. *-------------------------------------------------------------------------------
  347. *-- Programmer..: Ken Mayer (KENMAYER)
  348. *-- Date........: 04/26/1992
  349. *-- Notes.......: This function converts a Roman Numeral to an arabic one.
  350. *--               It parses the roman numeral into an array, and checks each 
  351. *--               character ... if the previous character causes the value to 
  352. *--               subtract (for example, IX = 9, not 10) we subtract that value, 
  353. *--               and then set the previous value to 0, otherwise we would get 
  354. *--               some odd values in return.
  355. *--               So far, it works fine.
  356. *-- Written for.: dBASE IV, 1.1
  357. *-- Rev. History: 07/15/1991 - original function.
  358. *--               04/26/1992 - Jay Parsons - shortened.
  359. *-- Calls.......: None
  360. *-- Called by...: Any
  361. *-- Usage.......: Arabic(<cRoman>)
  362. *-- Example.....: ?Arabic("XXIV")
  363. *-- Returns.....: Arabic number (from example, 24)
  364. *-- Parameters..: cRoman = character string containing roman numeral to be
  365. *--               converted.
  366. *-------------------------------------------------------------------------------
  367.  
  368.         parameters cRoman
  369.         private cRom,cLetrs,nLast,nAt,nVal,cChar,nArabic
  370.     
  371.         cRom = ltrim(trim(upper(cRoman))) && convert to all caps in case ...
  372.         cLetrs = "IVXLCDMWY"
  373.         nArabic = 0
  374.         nLast = 0
  375.         do while len( cRom ) > 0
  376.                 cChar = right( cRom, 1 )
  377.                 nAt = at( cChar, cLetrs )
  378.                 nVal= 10 ^ int( nAt/2 ) / iif(nAt/2 = int(nAt/2),2,1)
  379.                 do case
  380.                         case nAt = 0
  381.                                 nArabic = 0
  382.                                 exit
  383.                         case nAt >= nLast
  384.                                 nArabic = nArabic + nVal
  385.                                 nLast = nAt
  386.                         otherwise
  387.                                 if nAt/2 = int( nAt / 2 )
  388.                                         nArabic = 0
  389.                                         exit
  390.                                 else
  391.                                         nArabic = nArabic - nVal
  392.                                 endif
  393.                 endcase
  394.                 cRom = left( cRom, len( cRom ) - 1 )
  395.         enddo
  396.     
  397. RETURN nArabic
  398. *-- EoF: Arabic()
  399.  
  400. *-------------------------------------------------------------------------------
  401. *-- EoP: SCA.PRG
  402. *-------------------------------------------------------------------------------
  403.