From: an7689@anon.penet.fi
Subject: VCR Plus+ PlusCodes:  3 of 3
Organization: Anonymous contact service
X-Anonymously-To: rec.video
Date: Sat, 23 Jan 1993 12:25:00 GMT

      IMPLICIT INTEGER (A-Z)
      LOGICAL IAM
      CHARACTER QBUFR*20
      DIMENSION V(192), KEY(4), T(0:8), C(0:5), BM(10), B5(5), 
     *   CO(6), KMAT(6,10), D1(6), CHMAP(100)
      DATA IIN, IOUT, IFIN /0, 0, 10/,
     *  KEY(4), KEY(3), KEY(2), KEY(1)
     * /    9,      3,      7,      1 /
      DATA
     *  V(1), V(2), V(3), V(4), V(5), V(6), V(7), V(8), V(9),V(10)
     * /-99,  -99,  -99,  -99,  -99,  -99,  -99,  -99,    2,  -99/,
     * V(11),V(12),V(13),V(14),V(15),V(16),V(17),V(18),V(19),V(20)
     * /  0,  -99,  -99,  -99,  -99,    1,  -99,  -99,  -99,  -99/,
     * V(21),V(22),V(23),V(24),V(25),V(26),V(27),V(28),V(29),V(30)
     * /-99,  -99,  -99,  -99,  -99,  -99,  -99,  -99,  -99,  -99/,
     * V(31),V(32),V(33),V(34),V(35),V(36),V(37),V(38),V(39),V(40)
     * /-99,  -99,  -99,  -99,  -99,  -99,  -99,  -99,  -99,  -99/,
     * V(41),V(42),V(43),V(44),V(45),V(46),V(47),V(48),V(49),V(50)
     * /-99,  -99,  -99,  -99,  -99,  -99,  -99,  -99,  -99,  -99/
      DATA
     * V(51),V(52),V(53),V(54),V(55),V(56),V(57),V(58),V(59),V(60)
     * /-99,  -99,  -99,  -99,  -99,  -99,  -99,  -99,  -99,  -99/,
     * V(61),V(62),V(63),V(64),V(65),V(66),V(67),V(68),V(69),V(70)
     * /-99,  -99,  -99,  -99,  -99,  -99,  -99,  -99,  -99,  -99/,
     * V(71),V(72),V(73),V(74),V(75),V(76),V(77),V(78),V(79),V(80)
     * /-99,  -99,  -99,  -99,  -99,  -99,  -99,  -99,  -99,  -99/,
     * V(81),V(82),V(83),V(84),V(85),V(86),V(87),V(88),V(89),V(90)
     * /-99,  -99,  -99,  -99,  -99,  -99,  -99,  -99,  -99,  -99/,
     * V(91),V(92),V(93),V(94),V(95),V(96),V(97),V(98),V(99),V(100)
     * /-99,  -99,  -99,  -99,  -99,  -99,  -99,  -99,  -99,  -99/
      DATA
     * V(101),V(102),V(103),V(104),V(105)
     * / -99,    -99,   -99,   -99,   -99/,
     * V(106),V(107),V(108),V(109),V(110)
     * / -99,    -99,   -99,   -99,   -99/,
     * V(111),V(112),V(113),V(114),V(115)
     * / -99,    -99,   -99,   -99,   -99/,
     * V(116),V(117),V(118),V(119),V(120)
     * / -99,    -99,   -99,   -99,   -99/,
     * V(121),V(122),V(123),V(124),V(125)
     * / -99,    191,   -99,   -99,   -99/,
     * V(126),V(127),V(128),V(129),V(130)
     * / -99,    -99,   -99,   -99,   -99/,
     * V(131),V(132),V(133),V(134),V(135)
     * / -99,    -99,   -99,   -99,   -99/,
     * V(136),V(137),V(138),V(139),V(140)
     * / -99,    -99,   -99,   -99,   -99/,
     * V(141),V(142),V(143),V(144),V(145)
     * / -99,    -99,   -99,   -99,   -99/,
     * V(146),V(147),V(148),V(149),V(150)
     * / -99,    -99,   -99,   -99,   -99/
      DATA
     * V(151),V(152),V(153),V(154),V(155)
     * / -99,    -99,   -99,   -99,   -99/,
     * V(156),V(157),V(158),V(159),V(160)
     * / -99,    -99,   -99,   -99,   -99/,
     * V(161),V(162),V(163),V(164),V(165)
     * / -99,    -99,   -99,   -99,   -99/,
     * V(166),V(167),V(168),V(169),V(170)
     * / -99,    -99,   -99,   -99,   -99/,
     * V(171),V(172),V(173),V(174),V(175)
     * / -99,    -99,   -99,   -99,   -99/,
     * V(176),V(177),V(178),V(179),V(180)
     * / -99,    -99,   -99,   -99,   -99/,
     * V(181),V(182),V(183),V(184),V(185)
     * / -99,    -99,   -99,   -99,   -99/,
     * V(186),V(187),V(188),V(189),V(190)
     * / -99,    -99,   -99,   -99,   -99/,
     * V(191),V(192)
     * / -99,    -99/
C
      DO 1 I = 1, 100
    1 CHMAP(I) = I            
      INQUIRE (FILE='CHANNEL.MAP', EXIST=IAM)
      IF (IAM) THEN
         OPEN(UNIT=IFIN, FILE='CHANNEL.MAP', STATUS='OLD')
    2    READ(IFIN,*,END=4) OLD, NEW
         CHMAP(OLD) = NEW
         GOTO 2
      ENDIF
C Input
    4 CLOSE (IFIN)
      WRITE (IOUT,5)
    5 FORMAT (///
     *   29X,'VCRCode, Version 1.00'/
     *   15X,'A Program to Generate 1 to 6 Digit VCR Plus+ Codes'/
     *   /
     *   23X,'This program is brought to you by'/
     *   /
     *   32X,'The Good Doctor'/
     *   /
     *   9X,'It is based on information  appearing in Shirriff K,  Wel',
     *   'ch C,'/
     *   9X,'Kinsman A, "Decoding a VCR Controller Code,"  Cryptologia',
     *   ',  16'/
     *   27X,'(#3, July 1992), 227-234.'/
     *   //)
   10 WRITE (IOUT,11)
   11 FORMAT (//' Enter starting month/day/year',9X,'(mm/dd/yy)   '$)
      READ (IIN,'(A)') QBUFR
      IF (QBUFR.EQ.' ') STOP ' '
      CALL MPARSE(QBUFR, MONTH, DAY, YEAR, IERR)
      IF (IERR.EQ.1) GOTO 10
      IF (MONTH.LT.1 .OR. MONTH.GT.12) THEN
         WRITE (IOUT,12) MONTH
   12    FORMAT (' Month invalid:',I8,'   Must be in range 1 to 12.')
         GOTO 10
      ENDIF
C
      IF (DAY.LT.1 .OR. 
     *        ((MONTH.EQ.1 .OR. MONTH.EQ.3 .OR. MONTH.EQ.5 .OR. 
     *          MONTH.EQ.7 .OR. MONTH.EQ.8 .OR. MONTH.EQ.10 .OR. 
     *          MONTH.EQ.12) .AND. DAY.GT.31) .OR.
     *        ((MONTH.EQ.4 .OR. MONTH.EQ.6 .OR. MONTH.EQ.9 .OR. 
     *          MONTH.EQ.11) .AND. DAY.GT.30) .OR.
     *         (MONTH.EQ.2 .AND. DAY.GT.29)) THEN
         WRITE (IOUT,15) DAY
   15    FORMAT (' Day invalid:',I8)
         GOTO 10
      ENDIF
C
      IF (YEAR.LT.0 .OR. YEAR.GT.99) THEN
         WRITE (IOUT,17) YEAR
   17    FORMAT (' Year invalid:',I8,'   Must be in range 0 to 99.')
         GOTO 10
      ENDIF
      IF (MONTH.EQ.2 .AND. MOD(YEAR,4).NE.0 .AND. DAY.EQ.29) THEN
         WRITE (IOUT,18) YEAR
   18    FORMAT (' There is no February 29th in year',I3)
         GOTO 10
      ENDIF
C
   29 WRITE (IOUT,30)
   30 FORMAT (7X,'starting time',15X,'(hh:00|30 a|p)   '$)
C
      READ (IIN,'(A)') QBUFR
      CALL TPARSE(QBUFR,HR,MIN,AMPM,IERR)
      IF (IERR.EQ.1) GOTO 29
C
   38 WRITE (IOUT,39)
   39 FORMAT (7X,'channel',38X,TL1,' ',$)
      READ (IIN, *) CHNL
      IF (CHNL.LT.1) THEN
         WRITE (IOUT,40) CHNL
   40    FORMAT (' Channel invalid:',I8,'   Must be positive number.')
         GOTO 38
      ENDIF
      CHNL = CHMAP(CHNL)
C
   41 WRITE (IOUT,42)
   42 FORMAT (7X,'duration (# of half hours)',7X,'(1 to 10)   '$)
      READ (IIN, *) DUR
      IF (DUR.LT.1 .OR. DUR.GT.10) THEN
         WRITE (IOUT,43) DUR
   43    FORMAT (' Duration invalid:',I8,'   Must be in range 1 to 10.')
         GOTO 41
      ENDIF
C
      TABL = 48 * DUR - 24 * (AMPM - 1) - 2 * MOD(HR,12) - MIN / 30
      IF (TABL.GT.192) THEN
         TABL = TABL - 1
      ELSE
         TABL = V(TABL)
      ENDIF
C
   80 IF (TABL.EQ.-99) THEN
         WRITE (IOUT,90)
   90    FORMAT (/' This combination of start time and duration ',
     *       'not tabled.')
         GOTO 10
      ENDIF
C
      DO 100 K = 0, 8
      T(K) = MOD(TABL,2)
      TABL = TABL / 2
  100 CONTINUE
C
      CHNL = CHNL - 1
      DO 110 K = 0, 5
      C(K) = MOD(CHNL,2)
      CHNL = CHNL / 2
  110 CONTINUE
C
      BM(1) = T(3)
      BM(2) = C(2)
      BM(3) = C(3)
      BM(4) = T(4)
      BM(5) = T(5)
      BM(6) = T(6)
      BM(7) = C(4)
      BM(8) = T(7)
      BM(9) = C(5)
      BM(10) = T(8)
C
      MTOP = BM(10)
      DO 130 K = 9, 1, -1
  130 MTOP = 2 * MTOP + BM(K)
C
      IF (MTOP.EQ.0) THEN
         TOP = 0
         OFFSET = 0
         GOTO 200
      ELSE
         DTOP = 1 + IFIX(ALOG10(MTOP))
  140    K = IMAP(DAY,YEAR,MTOP,DTOP)
         IF (K.EQ.0) THEN
            MTOP = K
            GOTO 140
         ENDIF
         IF (1+IFIX(ALOG10(K)).NE.DTOP) THEN
            MTOP = K
            GOTO 140
         ENDIF
         TOP = K
      ENDIF
C
      XTOP = TOP
      OFFSET = OFF(DAY,YEAR,XTOP,DTOP)
C
  200 B5(1) = T(0)
      B5(2) = C(0)
      B5(3) = T(1)
      B5(4) = C(1)
      B5(5) = T(2)
C
      X5 = B5(5)
      DO 230 K = 4, 1, -1
  230 X5 = 2 * X5 + B5(K)
C
      REMAIN = ADDEND(DAY * (MONTH + 1) + OFFSET, 32, X5)
      CODE = 1000 * TOP + 32 * (DAY - 1) + REMAIN + 1
      NC = 1 + IFIX(ALOG10(CODE))
C CO(), digits of CODE
C Lowest order digit goes in (1)
      XCODE = CODE
  340 DO 350 I = 1, NC
      CO(I) = MOD(XCODE, 10)
      XCODE = XCODE / 10
  350 CONTINUE
C No carry multiply
      DO 360 I = 1, NC
      DO 360 J = 1, 10
  360 KMAT(I,J) = 0
      DO 380 I = 1, NC
      DO 380 J = 1, 4
  380 KMAT(I,J+I-1) = MOD(CO(I)*KEY(J),10)
      DO 390 I = 1, 6
  390 D1(I) = 0
      DO 420 K = 1, NC
      DO 410 KK = 1, NC
  410 D1(K) = D1(K) + KMAT(KK,K)
      D1(K) = MOD (D1(K),10)
  420 CONTINUE
      XCODE = D1(NC)
      DO 430 I = NC-1, 1, -1
  430 XCODE = 10 * XCODE + D1(I)
      IF (D1(NC).EQ.0) GOTO 340
      WRITE (IOUT,500) XCODE
  500 FORMAT (/' The VCR Plus+ PlusCode is ',I6)
C      
      GOTO 10
      END
C***********************************************************************
      INTEGER FUNCTION OFF(DAY,YEAR,TOP,NT)
      IMPLICIT INTEGER (A-Z)
C
      OFF = MOD(TOP, 10) + MOD(TOP/10, 10) + MOD(TOP/100, 10)
   40 DO 50 I = 0, MOD(YEAR,16)
   50 OFF = OFF + MOD(MAP(DAY,I,TOP,NT), 10)
      TOP = MAP(DAY,YEAR,TOP,NT)
      IF (TOP.LT.10**(NT-1)) GOTO 40
C
   60 OFF = MOD(OFF,32)
      RETURN
      END
C***********************************************************************
      INTEGER FUNCTION MAP(DAY,YR,TOP,NT)
      IMPLICIT INTEGER (A-Z)
      DIMENSION D(0:2)
C
      YEAR = MOD(YR,16)
      XTOP = TOP
      DO 10 I = 0, 2
      D(I) = MOD(XTOP,10)
      XTOP = XTOP / 10
   10 CONTINUE
C
      F0 = 1
      F1 = MOD(YEAR+1,10)
      F2 = MOD((YEAR+1)*(YEAR+2)/2,10)
      F3 = MOD((YEAR+1)*(YEAR+2)*(YEAR+3)/6,10)
      IF (NT.EQ.1) THEN
         MAP = MOD(D(0)*F0+DAY*F1,10)
      ELSEIF (NT.EQ.2) THEN
         MAP = 10 * MOD(D(1)*F0+DAY*F1,10) + 
     *               MOD(D(0)*F0+D(1)*F1+DAY*F2,10)
      ELSE
         MAP = 100 * MOD(D(2)*F0+DAY*F1,10) + 
     *           10 * MOD(D(1)*F0+D(2)*F1+DAY*F2,10) +
     *                 MOD(D(0)*F0+D(1)*F1+D(2)*F2+DAY*F3,10)
      ENDIF
      RETURN
      END
C***********************************************************************
      INTEGER FUNCTION IMAP(DAY,YR,TOP,NT)
      IMPLICIT INTEGER (A-Z)
      DIMENSION N(0:2)
C
      YEAR = MOD(YR,16)
      XTOP = TOP
      DO 10 I = 0, 2
      N(I) = MOD(XTOP,10)
      XTOP = XTOP / 10
   10 CONTINUE
C
      F0 = 1
      F1 = MOD(YEAR+1,10)
      F2 = MOD((YEAR+1)*(YEAR+2)/2,10)
      F3 = MOD((YEAR+1)*(YEAR+2)*(YEAR+3)/6,10)
C
      X1 = ADDEND(DAY*F1,10,N(NT-1))
      IF (NT.EQ.1) THEN
         IMAP = X1
         RETURN
      ENDIF
C
      X2 = ADDEND(X1*F1+DAY*F2,10,N(NT-2))
      IF (NT.EQ.2) THEN
         IMAP = 10 * X1 + X2
         RETURN
      ENDIF
C
      X3 = ADDEND(X2*F1+X1*F2+DAY*F3,10,N(0))
      IMAP = 100 * X1 + 10 * X2 + X3
      RETURN
      END
C***********************************************************************
      INTEGER FUNCTION ADDEND(A,B,R)
      IMPLICIT INTEGER (A-Z)
C Returns X such that  R = (A+X) mod B
      Y = MOD(A,B)
      IF (Y.LE.R) THEN
         ADDEND = R - Y
      ELSE
         ADDEND = B - (Y - R)
      ENDIF
      RETURN
      END
C***********************************************************************
      SUBROUTINE TPARSE(QTC,HR,MIN,AMPM,IERR)
      IMPLICIT INTEGER (A-Z)
      CHARACTER QTC*20, QT*20, QT1(20)*1
      EQUIVALENCE (QT,QT1)
      DATA IOUT /0/
C
      IERR = 1
      QT = QTC
      IF (QT.EQ.' ') RETURN
C Strip spaces : -
      LQ = 0
      DO 10 I = 1, 20
      IF (QT1(I).NE.' ' .AND. QT1(I).NE.':' .AND. QT1(I).NE.'-') THEN
         LQ = LQ + 1
         QT1(LQ) = QT1(I)
      ENDIF
   10 CONTINUE
C AM/PM
      IF (QT1(LQ).EQ.'a' .OR. QT1(LQ).EQ.'A') THEN
         AMPM = 1
      ELSEIF (QT1(LQ).EQ.'p' .OR. QT1(LQ).EQ.'P') THEN
         AMPM = 2
      ELSE
         WRITE (IOUT,20) 
   20    FORMAT (' Starting time must end in A or P.')
         RETURN
      ENDIF
C
      LQ = LQ - 1 
      DO 30 I = 1, LQ
      IF (QT1(I).LT.'0' .OR. QT1(I).GT.'9') THEN
         WRITE (IOUT,40) QTC
   40    FORMAT (' Starting time must be of the form  hh:00|30 a|p:  ',
     *     A10)
         RETURN
      ENDIF
   30 CONTINUE
C Minutes
      IF (LQ.EQ.4 .AND. QT(3:4).EQ.'00') THEN
         MIN = 0
         LQ = 2
      ELSEIF (LQ.EQ.4 .AND. QT(3:4).EQ.'30') THEN
         MIN = 30
         LQ = 2
      ELSEIF (LQ.EQ.4) THEN
         WRITE (IOUT,50) QT(3:4)
   50    FORMAT (' Minutes invalid:',''A2'','   Must be 00 or 30.')
         RETURN
      ELSEIF (LQ.EQ.3 .AND. QT(2:3).EQ.'00') THEN
         MIN = 0
         LQ = 1
      ELSEIF (LQ.EQ.3 .AND. QT(2:3).EQ.'30') THEN
         MIN = 30
         LQ = 1
      ELSEIF (LQ.EQ.3) THEN
         WRITE (IOUT,50) QT(2:3)
         RETURN
      ELSE
         MIN = 0
      ENDIF
C Hour
      READ (QT(1:LQ),'(I2)') HR
      IF (HR.LT.1 .OR.HR.GT.12) THEN
         WRITE (IOUT,60) HR
   60    FORMAT (' Hour invalid:',I8,'   Must be in range 1 to 12.')
         RETURN
      ENDIF
      IERR = 0
      RETURN
      END
C***********************************************************************
      SUBROUTINE MPARSE(QDC,MO,DA,YR,IERR)
      IMPLICIT INTEGER (A-Z)
      DIMENSION NSL(2)
      CHARACTER QDC*20, QD*20, QD1(20)*1
      EQUIVALENCE (QD,QD1)
      DATA IOUT /0/
C
      IERR = 1
      QD = QDC
      IF (QD.EQ.' ') RETURN
C Must have embedded slashes
      KSL = 0
      DO 10 I = 1, 20
      IF (QD1(I).EQ.'/') KSL = KSL + 1
   10 CONTINUE
      IF (KSL.NE.2) THEN
         WRITE (IOUT,20)
   20    FORMAT (' Month, day, and year must be separated by /''s.')
         RETURN
      ENDIF
C Strip spaces; check digits
      LQ = 0
      ISL = 0
      DO 40 I = 1, 20
      IF (QD1(I).NE.' ') THEN
         IF (QD1(I).EQ.'/') THEN
            LQ = LQ + 1
            QD1(LQ) = QD1(I)
            ISL = ISL + 1
            NSL(ISL) = LQ
         ELSEIF (QD1(I).GE.'0' .AND. QD1(I).LE.'9') THEN
            LQ = LQ + 1
            QD1(LQ) = QD1(I)
         ELSE
            WRITE (IOUT,30) QDC
   30       FORMAT (' Starting date must be of the form  mm/dd/yy:'
     *        A20)
            RETURN
         ENDIF
      ENDIF
   40 CONTINUE
      IF (LQ.NE.NSL(2)+2) THEN
        WRITE (IOUT,30) QDC
        RETURN
      ENDIF
C Month
      READ (QD(1:NSL(1)-1),'(I2)') MO
      READ (QD(NSL(1)+1:NSL(2)-1),'(I2)') DA
      READ (QD(LQ-1:LQ),'(I2)') YR
      IERR = 0
      RETURN
      END
C***********************************************************************
-------------------------------------------------------------------------
To find out more about the anon service, send mail to help@anon.penet.fi.
Due to the double-blind system, any replies to this message will be anonymized,
and an anonymous id will be allocated automatically. You have been warned.
Newsgroups: rec.video