The QBasic / QB64 Discussion Forum      Other Subforums, Links and Downloads
 
 

 Return to Index  

Version 1c

February 24 2007 at 8:23 PM
No team yet  (Premier Login iorr5t)
Forum Owner


Response to Yo, Pete

 
DECLARE FUNCTION GenTime% (f$)
DECLARE SUB FinalPhase ()
DECLARE FUNCTION GenPLine$ (CurStory AS INTEGER)
DECLARE FUNCTION LineSub% (C$)
DECLARE SUB FillHeader ()
DECLARE SUB ShowHeader ()
DECLARE SUB F1 (i%, n$, r%, C%, l%)
DECLARE FUNCTION GetField$ (r%, C%, l%)
DECLARE SUB EstablishRundownID ()
DIM SHARED MyErr AS INTEGER
DIM i AS INTEGER, j AS INTEGER
' ##  Initialize Rundown ID
DIM SHARED Status AS STRING * 99
DIM SHARED RunDownID AS STRING, FileId AS STRING
CALL EstablishRundownID
PRINT RunDownID, FileId

' ## Define Rundown Header
TYPE Header
n AS STRING * 16
r AS INTEGER
C AS INTEGER
l AS INTEGER
v AS STRING * 57
END TYPE
DIM SHARED Header(7) AS Header

' ## Define Story Line Format
CONST NumberOfAttributes = 6
DIM SHARED Attribute(NumberOfAttributes) AS STRING
DIM SHARED AttributeStartL(NumberOfAttributes) AS INTEGER
DIM SHARED AttributeLength(NumberOfAttributes) AS INTEGER
DIM StartHere AS INTEGER: StartHere = 5

' ## Process Header
GOSUB InitHeaderConstants
CALL ShowHeader
OPEN FileId FOR INPUT AS #1: LINE INPUT #1, Status
CALL FillHeader

' ## Define Story Database
CONST MaxStories = 99
DIM SHARED Story(MaxStories, NumberOfAttributes) AS STRING
DIM SHARED Time(MaxStories) AS INTEGER
DIM SHARED TotalTime AS INTEGER, OldTime AS INTEGER

' ## Load Saved Stories
DIM SHARED NewStory AS INTEGER
DIM SHARED StoryL(MaxStories) AS STRING
DIM SHARED StoryT(MaxStories) AS INTEGER

IF EOF(1) THEN
  CLOSE
  OPEN FileId$ FOR OUTPUT AS #1
  PRINT #1, Status
  FOR i = 1 TO 7: PRINT #1, RTRIM$(Header(i).v): NEXT i
  NewStory = 1
ELSE
  FOR i = 1 TO MaxStories
    IF EOF(1) THEN EXIT FOR
    FOR j = 1 TO NumberOfAttributes
      IF EOF(1) THEN STOP: 'bad data file
      LINE INPUT #1, Story(i, j)
    NEXT j
      StoryL(i) = GenPLine(i)
  NEXT i
  NewStory = i
END IF
StoryL(NewStory) = GenPLine(NewStory)
CLOSE

' ## Header Finished
VIEW PRINT 10 TO 25
CONST Line1 = 10, LineMax = 20

' ## Input Stories
DO
  k% = LineSub("Show")
  DO
    p$ = "I = Input stories    F = Finished entering stories   E = Edit   I/F/E:  "
    LOCATE 22, 1: PRINT p$;
    k$ = UCASE$(GetField$(22, LEN(p$), 1)) + "x"
    LOCATE 22, 1: PRINT SPACE$(79);
    IF k$ = CHR$(27) + "x" THEN VIEW PRINT: CLS : SYSTEM
  LOOP WHILE INSTR("FxIxEx", k$) = 0
  IF k$ = "Fx" THEN EXIT DO
  IF k$ = "Ex" THEN
    SHELL "Notepad " + FileId
    OPEN "Fxx.sv2" FOR OUTPUT AS #1: PRINT #1, RunDownID: CLOSE
    RUN
  END IF
  LOCATE 22, 1: PRINT "Press ESC when finished."
  DO
    k% = LineSub("Show")
  LOOP WHILE LineSub("Get")
LOOP

' ## All data in place
ON TIMER(1) GOSUB Clock: GOSUB Clock: TIMER ON
CALL FinalPhase
VIEW PRINT: CLS
SYSTEM

Clock:
r7% = CSRLIN: c7% = POS(0): VIEW PRINT
LOCATE 1, 73: PRINT TIME$;
IF TotalTime <> LastTime THEN
  outt% = TotalTime \ 60
  outt$ = RIGHT$(STR$(100 + outt%), 2) + ":"
  outt% = TotalTime - (outt% * 60)
  outt$ = outt$ + RIGHT$(STR$(100 + outt%), 2)
  LOCATE 6, 64: PRINT outt$;
  LastTime = TotalTime
END IF
VIEW PRINT 10 TO 25: LOCATE r7%, c7%, 1
RETURN

GetMyErr: MyErr = ERR: RESUME NEXT

InitHeaderConstants:
CALL F1(1, "SCHEDULED TALENT", 3, 3, 41)
CALL F1(4, "FLOOR", 3, 63, 8)
CALL F1(2, "PRODUCER", 4, 3, 17)
CALL F1(3, "DIRECTOR", 4, 32, 19)
CALL F1(7, "TELE.", 4, 63, 8)
CALL F1(5, "TECHNICAL", 5, 3, 16)
CALL F1(6, "AUDIO", 5, 32, 22)
Attribute(1) = "        STORY         "
Attribute(2) = " SOURCE "
Attribute(3) = "   TALENT  "
Attribute(4) = "CAMERA"
Attribute(5) = "  TIME  "
Attribute(6) = "NTS"
FOR i = 1 TO NumberOfAttributes
  l% = LEN(Attribute(i))
  AttributeStartL(i) = StartHere
  AttributeLength(i) = l%
  StartHere = StartHere + l% + 3
NEXT i
RETURN

SUB EstablishRundownID
MyErr = 0: ON ERROR GOTO GetMyErr
OPEN "Fxx.sv2" FOR INPUT AS #1: LINE INPUT #1, RunDownID: CLOSE
KILL "Fxx.sv2"
IF MyErr > 0 THEN
  CLS : LOCATE 10, 10: PRINT "Enter a two-digit identity for this rundown"
  LOCATE , 13: PRINT "(Or just press Enter to terminate run)"
  PRINT : PRINT
  DO
    PRINT : LINE INPUT "ID (00-99): "; id$
    IF id$ = "" THEN SYSTEM
    IF LEN(id$) = 2 THEN
      IF INSTR("0123456789", LEFT$(id$, 1)) > 0 THEN
        IF INSTR("0123456789", RIGHT$(id$, 1)) > 0 THEN RunDownID = id$
      END IF
    END IF
  LOOP WHILE RunDownID$ = ""
END IF
FileId = "F" + RunDownID + ".sv2"
MyErr = 0: ON ERROR GOTO GetMyErr
OPEN FileId FOR INPUT AS #1
IF MyErr > 0 THEN
  ON ERROR GOTO 0
  DO
    PRINT "You want to create a NEW rundown. Correct? y/n: ";
    a$ = INPUT$(1): PRINT a$: a$ = UCASE$(a$)
    IF a$ = "N" THEN RUN
  LOOP WHILE a$ <> "Y"
  MyErr = 0: ON ERROR GOTO GetMyErr
  OPEN FileId FOR OUTPUT AS #1: PRINT #1, Status: CLOSE
  ON ERROR GOTO 0
  IF MyErr > 0 THEN PRINT "?? Unable to create "; FileId: SYSTEM
ELSE
  LINE INPUT #1, l$
  ON ERROR GOTO 0
  IF LEN(l$) <> LEN(Status) THEN
    PRINT "?? Bad format: "; FileId: SYSTEM
  END IF
END IF
CLOSE
END SUB

SUB F1 (i%, n$, r%, C%, l%)
Header(i%).n = n$
Header(i%).r = r%
Header(i%).C = C%
Header(i%).l = l%
END SUB

SUB FillHeader
DIM i AS INTEGER
FOR i = 1 TO 7
  v$ = SPACE$(Header(i).l)
  r% = Header(i).r
  C% = Header(i).C + LEN(RTRIM$(Header(i).n)) + 2
  IF EOF(1) THEN
    k$ = GetField(r%, C%, Header(i).l)
    IF k$ = CHR$(27) THEN EXIT FOR
    LSET v$ = k$
  ELSE
    LINE INPUT #1, l$: LSET v$ = l$
  END IF
  LOCATE r%, C%
  COLOR 15, 0: PRINT v$: COLOR 7, 0
  LSET Header(i).v = v$
NEXT i
IF i < 8 THEN
  COLOR 7, 0: CLS
  PRINT "Rundown"; RunDownID; " was not created."
  CLOSE
  KILL FileId
  SYSTEM
END IF
END SUB

SUB FinalPhase
IF NewStory < 2 THEN EXIT SUB
DIM i AS INTEGER, DoCurX AS INTEGER
FOR i = 1 TO 99
  SELECT CASE MID$(Status, i, 1)
  CASE "1", "2", " ":
  CASE ELSE: STOP: MID$(Status, i, 1) = " ": 'just remove that debug stop
  END SELECT
NEXT i
DIM s AS STRING: s = Status
DIM LastStory AS INTEGER: LastStory = NewStory - 1
FOR i = 1 TO LastStory: StoryT(i) = GenTime(Story(i, 5)): NEXT i
DIM StoryTop AS INTEGER, StoryBot AS INTEGER
IF LastStory + Line1 <= LineMax THEN
  StoryTop = 1
ELSE
  StoryTop = LastStory - LineMax + Line1 + 1
END IF
StoryBot = LastStory
DIM StoryCur AS INTEGER: StoryCur = LastStory
DIM LineCur AS INTEGER: LineCur = Line1 + StoryBot - StoryTop
GOSUB Refresh
DO
  DO: k$ = INKEY$: LOOP WHILE k$ = ""
  SELECT CASE k$
  CASE CHR$(27): EXIT DO
  CASE CHR$(0) + "H", "8":
    IF LineCur > Line1 THEN
      DoCurX = 0: GOSUB DoCur
      LineCur = LineCur - 1: StoryCur = StoryCur - 1
      DoCurX = 1: GOSUB DoCur
    ELSE
      IF StoryTop > 1 THEN
         StoryCur = StoryCur - 1
         StoryTop = StoryTop - 1
         StoryBot = StoryBot - 1
         GOSUB Refresh
      END IF
    END IF
  CASE CHR$(0) + "P", "2":
    IF (LineCur < LineMax - 1) AND (StoryCur < StoryBot) THEN
      DoCurX = 0: GOSUB DoCur
      LineCur = LineCur + 1: StoryCur = StoryCur + 1
      DoCurX = 1: GOSUB DoCur
    ELSE
      IF StoryBot < LastStory THEN
         StoryCur = StoryCur + 1
         StoryTop = StoryTop + 1
         StoryBot = StoryBot + 1
         GOSUB Refresh
      END IF
    END IF
  CASE " ":
    SELECT CASE MID$(s, StoryCur, 1)
    CASE " ": MID$(s, StoryCur, 1) = "1"
    CASE "1": MID$(s, StoryCur, 1) = "2"
    CASE "2": MID$(s, StoryCur, 1) = " "
    END SELECT
    GOSUB Refresh
  END SELECT
LOOP
IF s = Status THEN EXIT SUB
OPEN FileId FOR BINARY AS #1
FOR i = 1 TO 99
  IF MID$(s, i, 1) <> MID$(Status, i, 1) THEN
    v$ = MID$(s, i, 1):  PUT #1, i, v$
  END IF
NEXT i
CLOSE
EXIT SUB

Refresh:
CLS
TotalTime = 0
FOR i = 1 TO LastStory
  IF MID$(s, i, 1) <> "2" THEN TotalTime = TotalTime + StoryT(i)
NEXT i
FOR i = StoryTop TO StoryBot
  LOCATE Line1 + i - StoryTop, 1
  p$ = StoryL(i)
  SELECT CASE MID$(s, i, 1)
  CASE " ": PRINT p$;
  CASE "1": COLOR 0, 7: PRINT p$; : COLOR 7, 0
  CASE "2": COLOR 4, 3: PRINT p$; : COLOR 7, 0
  END SELECT
NEXT i
LOCATE 22, 1: PRINT "Arrow keys to select, spacebar to toggle, ESC to exit";
DoCurX = 1: GOSUB DoCur
RETURN

DoCur:
LOCATE LineCur, 3
IF DoCurX = 0 THEN PRINT ".";  ELSE PRINT ">";
RETURN
END SUB

FUNCTION GenPLine$ (CurStory AS INTEGER)
DIM i AS INTEGER
w$ = STR$(CurStory) + ". "
w$ = RIGHT$(w$, 4)
FOR i = 1 TO NumberOfAttributes - 1
  w2$ = SPACE$(AttributeLength(i)): LSET w2$ = Story(CurStory, i)
  w$ = w$ + w2$ + " | "
NEXT i
w2$ = SPACE$(AttributeLength(NumberOfAttributes))
LSET w2$ = Story(CurStory, NumberOfAttributes)
GenPLine$ = w$ + w2$
END FUNCTION

FUNCTION GenTime% (f$)
DIM y AS INTEGER: y = INSTR(f$, ":"): IF y < 3 THEN EXIT FUNCTION
IF LEN(f$) < y + 2 THEN EXIT FUNCTION
t% = VAL(MID$(f$, y - 2, 2)) * 60
GenTime% = t% + VAL(MID$(f$, y + 1, 2))
END FUNCTION

FUNCTION GetField$ (r%, C%, l%)
w$ = SPACE$(l%)
LOCATE r%, C%, 1: COLOR 1, 7: PRINT w$
LOCATE r%, C%
DIM fDat AS STRING
DO
  DO: k$ = INKEY$: LOOP WHILE k$ = ""
  IF k$ = "~" THEN STOP
  k% = (256 * (LEN(k$) - 1)) + ASC(RIGHT$(k$, 1))
  SELECT CASE k%
  CASE 13: EXIT DO
  CASE 27:
    IF LEN(fDat) > 0 THEN
      LOCATE r%, C%: PRINT w$: LOCATE r%, C%
      fDat = ""
    ELSE
      fDat = k$: EXIT DO
    END IF
  CASE 8:
    IF LEN(fDat) > 1 THEN fDat = LEFT$(fDat, LEN(fDat) - 1) ELSE fDat = ""
    LOCATE r%, C%: PRINT w$: LOCATE r%, C%: PRINT fDat;
  CASE 32 TO 255:
    PRINT k$;
    fDat = fDat + k$
    IF LEN(fDat) = l% THEN EXIT DO
  CASE ELSE:
'    LOCATE 25, 1: PRINT "debug: "; k%; " <------";
  END SELECT
LOOP
LOCATE r%, C%: COLOR 7, 0: PRINT w$
IF fDat$ <> CHR$(27) THEN LOCATE r%, C%: PRINT fDat
GetField$ = fDat
END FUNCTION

FUNCTION LineSub% (C$)
STATIC LineCur AS INTEGER
DIM i AS INTEGER, CurStory AS INTEGER
SELECT CASE C$
CASE "Show":
  SELECT CASE NewStory
  CASE 0: STOP' Bug. Too many stories
  CASE IS <= LineMax - Line1:
    LOCATE Line1, 1
    FOR CurStory = 1 TO NewStory - 1: PRINT GenPLine$(CurStory): NEXT CurStory
    LineCur = Line1 + CurStory - 1
  CASE ELSE:
    LOCATE Line1, 1
    FOR CurStory = NewStory - LineMax + Line1 TO NewStory - 1
      PRINT GenPLine$(CurStory)
    NEXT CurStory
    LineCur = LineMax
  END SELECT
CASE "Get":
  CurStory = NewStory: w$ = GenPLine$(CurStory): Blank$ = w$
  LOCATE LineCur, 1: PRINT Blank$
  FOR i = 1 TO NumberOfAttributes
    x$ = GetField(LineCur, AttributeStartL(i), AttributeLength(i))
    IF x$ = CHR$(27) THEN
      Story(NewStory, 1) = ""
      LOCATE LineCur, 1: PRINT Blank$
      EXIT FUNCTION
    END IF
    Story(NewStory, i) = x$
    MID$(w$, AttributeStartL(i), LEN(x$)) = x$
  NEXT i
  StoryL(NewStory) = w$
  OPEN FileId$ FOR APPEND AS #1
  FOR i = 1 TO NumberOfAttributes
    PRINT #1, Story(NewStory, i)
  NEXT i
  CLOSE
  NewStory = NewStory + 1
  LineSub% = -1
END SELECT
END FUNCTION

SUB ShowHeader
CLS
PRINT LEFT$(DATE$, 5);
LOCATE , 30: PRINT "R-U-N-D-O-W-N  #"; RunDownID;
DIM i AS INTEGER
FOR i = 1 TO 7
  LOCATE Header(i).r, Header(i%).C
  PRINT RTRIM$(Header(i).n); ": ";
  h$ = Header(i%).v
  IF ASC(h$) > 0 THEN COLOR 15, 0: PRINT RTRIM$(h$); : COLOR 7, 0
NEXT i
l$ = SPACE$(4)
FOR i = 1 TO 6
  l% = AttributeLength(i): l$ = l$ + STRING$(l%, "-")
  IF i < 6 THEN l$ = l$ + " | "
NEXT i
LOCATE 7, 1: PRINT l$
PRINT "    ";
FOR i = 1 TO 6
  l% = AttributeLength(i): PRINT Attribute(i);
  IF i = 6 THEN PRINT "" ELSE PRINT " | ";
NEXT i
PRINT l$
END SUB




    
This message has been edited by iorr5t on Feb 28, 2007 1:21 AM


 
 Respond to this message   
Response TitleAuthor and Date
Re: Version 1aAnonymous on Feb 26
   Madman411 - Try version 1bMac on Feb 27
      Re: Madman411 - Try version 1bAnonymous on Feb 27
         Make sure to enter your name when you postMac on Feb 27
            If you want to be able to edit data, you ned to use the INKEY$ routine I made for it.Pete on Feb 27
            Re: Make sure to enter your name when you postmadman411 on Feb 27
* Version 1c totals timeMac on Feb 28
Re: Version 1cmadman411 on Mar 1
   Re: Version 1cMac on Mar 1
      Version 1d with INKEY$ input added.Teams on Mar 2
         Mac, could you edit one line for me please...Pete on Mar 2
            Done. Slight problemMac on Mar 2
               I'll check with Mr/ Gates and get back to you...OK, he says to tell you it's not a bug...Pete on Mar 2
               Esc 'feature' deleted. Version 1d completed.Pete on Mar 4
                  Success!Mac on Mar 5
      Re: Version 1cmadman411 on Mar 4
 Copyright © 1999-2014 Network54. All rights reserved.   Terms of Use   Privacy Statement  

Newbies usually go to www.qbasic.com and click on The QBasic Forum
Forum regulars have their own ways, which include The QBasic Community Forums