Statistics: Posted by lisztfr — Tue Sep 27, 2022 6:28 am
Code:
LINE (160, 160) - (160 + 20, 160 - 50), jaune&
Code:
LINE (160, 160) - STEP(20, -50), jaune&
Code:
TYPE vec x AS INTEGER y AS INTEGEREND TYPEDIM v AS vecv.x = 20v.y = -50LINE(160, 160) - STEP(v.x, v.y), jaune&
Code:
DIM x0 AS INTEGER, x1 AS INTEGER, x2 AS INTEGER, x3 AS INTEGERx0 = -155x1 = 1x2 = 99x3 = INT(RND * 100)PRINT x0PRINT x1PRINT x2PRINT x3
Code:
DIM x(0 TO 3) AS INTEGERx(0) = -155x(1) = 1x(2) = 99x(3) = INT(RND * 100)FOR i% = 0 TO 3 PRINT x(i%)NEXT i%
Code:
CONST PI = 3.14159' our custom typeTYPE vec x AS INTEGER y AS INTEGEREND TYPE' our seconds hand stops arrayDIM sHand(0 to 59) AS vec' fill the arrayFOR i% = 0 to 59 ‘ adding 270 degrees here is equivalent to removing 15 seconds later ' 360 is divided by 60 because the hand makes 60 stops per cycle rad! = (270 + (i% * (360 \ 60))) * (PI / 180) ' 50 is the length of the hand sHand(i%).x = COS(rad!) * 50 sHand(i%).y = SIN(rad!) * 50NEXT i%
Code:
DO ' Seconds% contains a value between 0 and 59 Seconds% = VAL(RIGHT$(TIME$, 2)) ' Get deltas from our array LINE(160,160) - STEP(sHand(Seconds%).x, sHand(Seconds%).y), jaune&LOOP UNTIL LEN(INKEY$)
Statistics: Posted by MikeHawk — Sat Feb 26, 2022 3:17 pm
Code:
'Horloge analogique_TITLE "Horloge analogique vintage"SCREEN _NEWIMAGE(320, 320, 32)CONST Jaune& = _RGB32(255, 255, 0)CONST Cyan& = _RGB32(64, 224, 208)CONST Vert& = _RGB32(0, 255, 0)CONST Rouge& = _RGB32(255, 0, 0)CONST Noir& = _RGB32(0, 0, 0)Pi2! = 8 * ATN(1)sec! = Pi2! / 60min! = Pi2! / 60heure! = Pi2! / 60arc! = Pi2! / 12arc2! = Pi2! / 120FOR t! = 0 TO Pi2! STEP arc! cx% = CINT(COS(t!) * 70) cy% = CINT(SIN(t!) * 70) CIRCLE (cx% + 160, cy% + 160), .5, Vert& CIRCLE (cx% + 160, cy% + 160), 1, Vert& CIRCLE (cx% + 160, cy% + 160), 2, Vert&NEXT t!DO _LIMIT 1000 Year% = VAL(RIGHT$(DATE$, 4)) Jour% = VAL(RIGHT$(DATE$, 7)) Mois% = VAL(RIGHT$(DATE$, 11)) mois$ = LEFT$(DATE$, 2) M = VAL(mois$) SELECT CASE M CASE 1: Lune$ = "janvier" CASE 2: Lune$ = "f" + CHR$(130) + "vrier" CASE 3: Lune$ = "mars" CASE 4: Lune$ = "avril" CASE 5: Lune$ = "mai" CASE 6: Lune$ = "juin" CASE 7: Lune$ = "juillet" CASE 8: Lune$ = "ao" + CHR$(150) + "t" CASE 9: Lune$ = "septembre" CASE 10: Lune$ = "octobre" CASE 11: Lune$ = "novembre" CASE 12: Lune$ = "d" + CHR$(130) + "cembre" END SELECT LOCATE 2, 1 COLOR Cyan& PRINT " Horloge analogique vintage * "; COLOR Jaune& PRINT "(c) Wilou" Longueur = LEN(Lune$) + 17 Stars = ((40 - Longueur - 3) - 1) FOR I = 2 TO Stars LOCATE 3, I COLOR Cyan& PRINT "*"; NEXT I LOCATE 3, (40 - Longueur - 3) PRINT Jour%; Lune$; Year%; "| "; TIME$ Seconds% = VAL(RIGHT$(TIME$, 2)) - 15 s! = sec! * Seconds% Minutes% = VAL(RIGHT$(TIME$, 5)) - 15 M! = min! * Minutes% Heure% = VAL(RIGHT$(TIME$, 8)) - 15 H! = (heure! * 5) * Heure% IF Heure% >= 13 OR Heure% <= 24 THEN Heure% = Heure% - 12 IF VAL(RIGHT$(TIME$, 5)) = 0 AND VAL(RIGHT$(TIME$, 2)) = 0 THEN _LIMIT 1000 BEEP END IF Sx% = CINT(COS(s!) * 50) Sy% = CINT(SIN(s!) * 50) Mx% = CINT(COS(M!) * 60) My% = CINT(SIN(M!) * 60) Hx% = CINT(COS(H!) * 45) Hy% = CINT(SIN(H!) * 45) FOR I = 6 TO 59 STEP 6 IF VAL(RIGHT$(TIME$, 5)) >= I THEN _LIMIT 1000 H! = H! + arc2! Hx% = CINT(COS(H!) * 45) Hy% = CINT(SIN(H!) * 45) END IF NEXT I LINE (160, 160)-(Mx% + 160, My% + 160), Jaune& LINE (160, 160)-(Hx% + 160, Hy% + 160), Jaune& CIRCLE (160, 160), 1, Rouge& CIRCLE (160, 160), 2, Rouge& CIRCLE (160, 160), 3, Rouge& LINE (160, 160)-(Sx% + 160, Sy% + 160), Rouge& DO _LIMIT 1000 Verif% = VAL(RIGHT$(TIME$, 2)) - 15 Verif1% = VAL(RIGHT$(TIME$, 5)) - 15 Verif2% = VAL(RIGHT$(TIME$, 8)) - 15 LOOP UNTIL Verif% <> Seconds% OR Verif1% <> Minutes% OR Verif2% <> Heure% _DISPLAY LINE (160, 160)-(Sx% + 160, Sy% + 160), Noir& LINE (160, 160)-(Mx% + 160, My% + 160), Noir& LINE (160, 160)-(Hx% + 160, Hy% + 160), Noir& LOCATE 18, 4 COLOR Jaune& PRINT "Clic gauche | <"; CHR$(144); "chap> pour quitter" Mouse = _MOUSEINPUT K$ = INKEY$ IF K$ = CHR$(27) OR _MOUSEBUTTON(1) THEN SYSTEMLOOP UNTIL INKEY$ = CHR$(27)
Statistics: Posted by wilou — Fri Feb 25, 2022 9:56 am
I'm so stupid sometimes. At the beginning, I used arc2!, then two times arc2! then 3 times... But when I use arc2! for the first time (or heure!), the new H! is H! + heure! so I just have to add heure! again, not two, three or four times heure! (I had only considered the initial H! and not the H! that was increasing each 12 minutes)!For a reason I ignore, I must do the same routine in the four "if... end if", as if the minutes influenced the hours (M! influences H!)?
Statistics: Posted by wilou — Wed Feb 23, 2022 2:02 pm
Code:
DIM t AS LONGDIM s AS INTEGER, m AS INTEGER, h AS INTEGERDIM sA AS INTEGER, mA AS INTEGER, hA as INTEGERt = CLNG(TIMER) ' get the integer part of the number of seconds since midnights = t MOD 60 ' seconds - MOD (modulo) returns the remainder of an integral divisionm = (t \ 60) MOD 60 ' minutes - backslash for integral division (no fractional part)h = t \ 3600 ' hours (3600 is the number of seconds in an hour)
Code:
sA = 360 / 60 * s ' angle for the second hand, in degreesmA = 360 / 60 * m ' angle for the minute hand, in degrees
Code:
hA = (360 / 12) * (h MOD 12) ' angle for the "hard" hour hand, in degrees
Code:
DIM h2 AS INTEGERDIM h2A AS INTEGERh2 = h MOD 12 ' hour, in range 0-11h2 = h2 * 60 ' hour in minutes, in range 0-660 (661 values, max is 11 * 60)h2 = h2 + m ' hour with minutes included, in range 0-719 (720 values, max is 11 * 60 + 59)
Code:
h2A = (360 / 720) * h2 ' angle for the "soft" hour hand, in degrees
Statistics: Posted by MikeHawk — Tue Feb 22, 2022 10:24 pm
Code:
'Horloge analogique_TITLE "Horloge analogique vintage"SCREEN _NEWIMAGE(640, 320, 32)Blanc& = _RGB32(255, 255, 255)Jaune& = _RGB32(255, 255, 0)Cyan& = _RGB32(64, 224, 208)Vert& = _RGB32(0, 255, 0)Rouge& = _RGB32(255, 0, 0)Noir& = _RGB32(0, 0, 0)Gris& = _RGB32(63, 63, 63)Pi2! = 8 * ATN(1)sec! = Pi2! / 60min! = Pi2! / 60heure! = Pi2! / 60arc! = Pi2! / 12arc2! = Pi2! / 60FOR t! = 0 TO Pi2! STEP arc! cx% = CINT(COS(t!) * 70) cy% = CINT(SIN(t!) * 70) CIRCLE (cx% + 320, cy% + 160), 1, Vert& CIRCLE (cx% + 320, cy% + 160), 2, Vert&NEXT t!DO _LIMIT 1000 CIRCLE (320, 160), 1, Blanc& CIRCLE (320, 160), 2, Blanc& CIRCLE (320, 160), 3, Blanc& Year% = VAL(RIGHT$(DATE$, 4)) Jour% = VAL(RIGHT$(DATE$, 7)) Mois% = VAL(RIGHT$(DATE$, 11)) LOCATE 2, 28 COLOR Cyan& mois$ = LEFT$(DATE$, 2) M = VAL(mois$) SELECT CASE M CASE 1: Lune$ = "janvier" CASE 2: Lune$ = "février" CASE 3: Lune$ = "mars" CASE 4: Lune$ = "avril" CASE 5: Lune$ = "mai" CASE 6: Lune$ = "juin" CASE 7: Lune$ = "juillet" CASE 8: Lune$ = "août" CASE 9: Lune$ = "septembre" CASE 10: Lune$ = "octobre" CASE 11: Lune$ = "novembre" CASE 12: Lune$ = "décembre" END SELECT Longueur = LEN(Lune$) + 17 LOCATE 2, (80 - Longueur - 3) PRINT Jour%; Lune$; Year%; "| "; TIME$ Seconds% = VAL(RIGHT$(TIME$, 2)) - 15 S! = sec! * Seconds% Minutes% = VAL(RIGHT$(TIME$, 5)) - 15 M! = min! * Minutes% Heure% = VAL(RIGHT$(TIME$, 8)) - 15 H! = (heure! * 5) * Heure% IF Heure% >= 13 OR Heure% <= 24 THEN Heure% = Heure% - 12 IF VAL(RIGHT$(TIME$, 5)) = 0 AND VAL(RIGHT$(TIME$, 2)) = 0 THEN _LIMIT 1000 BEEP END IF Sx% = CINT(COS(S!) * 50) Sy% = CINT(SIN(S!) * 50) Mx% = CINT(COS(M!) * 60) My% = CINT(SIN(M!) * 60) Hx% = CINT(COS(H!) * 45) Hy% = CINT(SIN(H!) * 45) IF VAL(RIGHT$(TIME$, 5)) >= 12 THEN _LIMIT 1000 H! = H! + heure! Hx% = CINT(COS(H!) * 45) Hy% = CINT(SIN(H!) * 45) END IF IF VAL(RIGHT$(TIME$, 5)) >= 24 THEN _LIMIT 1000 H! = H! + heure! Hx% = CINT(COS(H!) * 45) Hy% = CINT(SIN(H!) * 45) END IF IF VAL(RIGHT$(TIME$, 5)) >= 36 THEN _LIMIT 1000 H! = H! + heure! Hx% = CINT(COS(H!) * 45) Hy% = CINT(SIN(H!) * 45) END IF IF VAL(RIGHT$(TIME$, 5)) >= 48 THEN _LIMIT 1000 H! = H! + heure! Hx% = CINT(COS(H!) * 45) Hy% = CINT(SIN(H!) * 45) END IF LINE (320, 160)-(Sx% + 320, Sy% + 160), Rouge& LINE (320, 160)-(Mx% + 320, My% + 160), Jaune& LINE (320, 160)-(Hx% + 320, Hy% + 160), Jaune& DO _LIMIT 1000 Verif% = VAL(RIGHT$(TIME$, 2)) - 15 Verif1% = VAL(RIGHT$(TIME$, 5)) - 15 Verif2% = VAL(RIGHT$(TIME$, 8)) - 15 LOOP UNTIL Verif% <> Seconds% OR Verif1% <> Minutes% OR Verif2% <> Heure% _DISPLAY LINE (320, 160)-(Sx% + 320, Sy% + 160), Noir& LINE (320, 160)-(Mx% + 320, My% + 160), Noir& LINE (320, 160)-(Hx% + 320, Hy% + 160), Noir& LOCATE 18, 45 COLOR Jaune& PRINT "Clic gauche ou <"; CHR$(144); "chap> pour quitter" Mouse = _MOUSEINPUT K$ = INKEY$ IF K$ = CHR$(27) OR _MOUSEBUTTON(1) THEN SYSTEMLOOP UNTIL INKEY$ = CHR$(27)
Statistics: Posted by wilou — Tue Feb 22, 2022 9:33 pm
Code:
'Horloge analogique_TITLE "Horloge analogique vintage"SCREEN _NEWIMAGE(640, 320, 32)Blanc& = _RGB32(255, 255, 255)Jaune& = _RGB32(255, 255, 0)Cyan& = _RGB32(64, 224, 208)Vert& = _RGB32(0, 255, 0)Rouge& = _RGB32(255, 0, 0)Noir& = _RGB32(0, 0, 0)Gris& = _RGB32(63, 63, 63)Pi2! = 8 * ATN(1)sec! = Pi2! / 60min! = Pi2! / 60heure! = Pi2! / 60arc! = Pi2! / 12arc2! = Pi2! / 60FOR t! = 0 TO Pi2! STEP arc! cx% = CINT(COS(t!) * 70) cy% = CINT(SIN(t!) * 70) CIRCLE (cx% + 320, cy% + 160), 1, Vert& CIRCLE (cx% + 320, cy% + 160), 2, Vert&NEXT t!DO _LIMIT 1000 CIRCLE (320, 160), 1, Blanc& CIRCLE (320, 160), 2, Blanc& CIRCLE (320, 160), 3, Blanc& Year% = VAL(RIGHT$(DATE$, 4)) Jour% = VAL(RIGHT$(DATE$, 7)) Mois% = VAL(RIGHT$(DATE$, 11)) LOCATE 2, 28 COLOR Cyan& mois$ = LEFT$(DATE$, 2) M = VAL(mois$) SELECT CASE M CASE 1: Lune$ = "janvier" CASE 2: Lune$ = "février" CASE 3: Lune$ = "mars" CASE 4: Lune$ = "avril" CASE 5: Lune$ = "mai" CASE 6: Lune$ = "juin" CASE 7: Lune$ = "juillet" CASE 8: Lune$ = "août" CASE 9: Lune$ = "septembre" CASE 10: Lune$ = "octobre" CASE 11: Lune$ = "novembre" CASE 12: Lune$ = "décembre" END SELECT Longueur = LEN(Lune$) + 17 LOCATE 2, (80 - Longueur - 3) PRINT Jour%; Lune$; Year%; "| "; TIME$ Seconds% = VAL(RIGHT$(TIME$, 2)) - 15 S! = sec! * Seconds% Minutes% = VAL(RIGHT$(TIME$, 5)) - 15 M! = min! * Minutes% Heure% = VAL(RIGHT$(TIME$, 8)) - 15 H! = (heure! * 5) * Heure% IF Heure% >= 13 OR Heure% <= 24 THEN Heure% = Heure% - 12 IF VAL(RIGHT$(TIME$, 5)) >= 12 THEN _LIMIT 1000 H! = H! + 0.016 END IF IF VAL(RIGHT$(TIME$, 5)) >= 24 THEN _LIMIT 1000 H! = H! + 0.033 END IF IF VAL(RIGHT$(TIME$, 5)) >= 36 THEN _LIMIT 1000 H! = H! + 0.05 END IF IF VAL(RIGHT$(TIME$, 5)) >= 48 THEN _LIMIT 1000 H! = H! + 0.067 END IF IF VAL(RIGHT$(TIME$, 5)) = 0 AND VAL(RIGHT$(TIME$, 2)) = 0 THEN _LIMIT 1000 BEEP END IF Sx% = CINT(COS(S!) * 50) Sy% = CINT(SIN(S!) * 50) Mx% = CINT(COS(M!) * 60) My% = CINT(SIN(M!) * 60) Hx% = CINT(COS(H!) * 45) Hy% = CINT(SIN(H!) * 45) LINE (320, 160)-(Sx% + 320, Sy% + 160), Rouge& LINE (320, 160)-(Mx% + 320, My% + 160), Jaune& LINE (320, 160)-(Hx% + 320, Hy% + 160), Jaune& DO _LIMIT 1000 Verif% = VAL(RIGHT$(TIME$, 2)) - 15 Verif1% = VAL(RIGHT$(TIME$, 5)) - 15 Verif2% = VAL(RIGHT$(TIME$, 8)) - 15 LOOP UNTIL Verif% <> Seconds% OR Verif1% <> Minutes% OR Verif2% <> Heure% _DISPLAY LINE (320, 160)-(Sx% + 320, Sy% + 160), Noir& LINE (320, 160)-(Mx% + 320, My% + 160), Noir& LINE (320, 160)-(Hx% + 320, Hy% + 160), Noir& LOCATE 18, 45 COLOR Jaune& PRINT "Clic gauche ou <"; CHR$(144); "chap> pour quitter" Mouse = _MOUSEINPUT K$ = INKEY$ IF K$ = CHR$(27) OR _MOUSEBUTTON(1) THEN SYSTEMLOOP UNTIL INKEY$ = CHR$(27)
Code:
IF VAL(RIGHT$(TIME$, 5)) >= 12 THEN _LIMIT 1000 H! = H! + 0.016 END IF IF VAL(RIGHT$(TIME$, 5)) >= 24 THEN _LIMIT 1000 H! = H! + 0.033 END IF IF VAL(RIGHT$(TIME$, 5)) >= 36 THEN _LIMIT 1000 H! = H! + 0.05 END IF IF VAL(RIGHT$(TIME$, 5)) >= 48 THEN _LIMIT 1000 H! = H! + 0.067 END IF
Statistics: Posted by wilou — Tue Feb 22, 2022 7:13 am
Code:
; pushing registers to stack so they can be restored to their initial value9C PUSHF50 PUSH AX53 PUSH BX51 PUSH CX52 PUSH DX1E PUSH DS56 PUSH SI06 PUSH ES57 PUSH DI; port readingEA 60 IN AL, 60 ; Read port 0x60, store in ALB4 01 MOV AH, 01 ; Assume the key is pressedA8 80 TEST AL, 80 ; Test bit-7 in AL, modifies Sign, Zero and Parity flag register.74 04 JZ 4 ; If Zero flag is SET, skip 4 bytes (2 instructions)B4 00 MOV AH, 00 ; The key was in fact released24 7F AND AL, 7F ; Strip bit-7 from AL (only keep scancode); getting offset from begining of the arrayD0 E0 SHL AL, 1 ; Multiply AL by 2 (target is an INTEGER array of 129 elements)88 C3 MOV BL, AL ; Set BX (lower byte) to ALB7 00 MOV BH, 00 ; Set BX (high byte) to 0B0 00 MOV AL, 00 ; Set AL to 0; going to the array memory address and write key status2E CS: ; Change code segment, set BX (offset)03 1E 12 00 ADD BX, [0012] ; Add BX to the value stored at 0x12 (array memory offset)2E CS: ; Change code segment, set DS (segment)8E 1E 10 00 MOV DS, [0010] ; Set DS to the value stored at 0x10 (array memory segment)86 E0 XCHG AH, AL ; Swap AH and AL (AH contains the key status)89 07 MOV [BX], AX ; Write AX (2 bytes) to [BX] (array memory offset); the rest is the standard:; acknowledge interrupt; restore registers with POP and POPF; terminate interrupt execution with IRET
Code:
; pushing registers like aboveEA 60 IN AL, 60 ; Read port 0x60, store in ALB4 01 MOV AH, 01 ; Assume the key is pressedA8 80 TEST AL, 80 ; Test bit-7 in AL, modifies Sign, Zero and Parity flag register.74 04 JZ 4 ; If Zero flag is SET, skip 4 bytes (2 instructions)B4 00 MOV AH, 00 ; Our bad, key is actually released.24 7F AND AL, 7F ; Only preserve bits 6-0 in AL, discard bit 7.88 C3 MOV BL, AL ; Set BX to scancode: BL = ALB7 00 MOV BH, 0 ; Set BX to scancode: BH = 02E 88 27 MOV CS:[BX], AH ; Copy key status to specified address; the rest is the standard:; acknowledge interrupt; restore registers with POP and POPF; terminate interrupt execution with IRET
Code:
'$INCLUDE: 'QB.BI'DECLARE SUB memFree (segAdr AS INTEGER)DECLARE FUNCTION memAlloc% (numBytes AS LONG)DECLARE FUNCTION keyInit% ()DIM keySegm AS INTEGER, tmr AS DOUBLECLStmr = TIMER + 5keySegm = keyInit%DODEF SEG = keySegmLOCATE 1, 1FOR i% = 0 TO 128PRINT PEEK(i%);NEXT i%LOOP UNTIL (tmr < TIMER)keySegm = keyInit%FUNCTION keyInit%STATIC oldISRSeg AS INTEGER, oldISROfs AS INTEGER, newISRSeg AS INTEGERDIM regs AS RegTypeXIF (newISRSeg = 0) THEN' Reserve memory for buffer & codenewISRSeg = memAlloc%(182) ' key status buffer (129) + code (53)' Clear key strokes (starting at offset 0 of segment [newISRSeg])DEF SEG = newISRSegFOR i% = 0 TO 128POKE i%, 0NEXT i%' Write code (starting at offset 129 of segment [newISRSeg])FOR i% = 0 TO 52POKE i% + 129, VAL("&H" + MID$("FB9C505351521E560657E460B401A8807404B400247F88C3B7002E8827E4610C80E661247FE661B020E6205F075E1F5A595B589DCF", 1 + i% * 2, 2))NEXT i%' Preserve vector interrupt 9 (BIOS keyboard ISR)regs.ax = &H3509CALL INTERRUPTX(&H21, regs, regs)oldISRSeg = regs.esoldISROfs = regs.bx' Clear keyboard bufferDEF SEG = 0POKE (&H41A), PEEK(&H41C)DEF SEG' Hook custom keyboard handlerregs.ax = &H2509regs.ds = newISRSeg ' interrupt code (and buffer) memory segmentregs.dx = 129 ' interrupt code offsetCALL INTERRUPTX(&H21, regs, regs)ELSE' Restore BIOS keyboard ISRregs.ax = &H2509regs.ds = oldISRSegregs.dx = oldISROfsCALL INTERRUPTX(&H21, regs, regs)' Deallocate memory reserved for buffer & codememFree newISRSegEND IFkeyInit% = newISRSeg ' offset to key status bufferEND FUNCTION'''' QuickBASIC always reserves the largest block of memory available for'' the far heap. If we need to allocate memory for our purpose, we must'' first tell QuickBASIC to free part of that memory.''FUNCTION memAlloc% (numBytes AS LONG)DIM memReq AS INTEGER, junk AS LONG, regs AS RegTypeX' Paragraphs are groups of 16 bytesmemReq = (numBytes \ 16) - ((numBytes AND 15) > 0)' Tell QuickBASIC to free some memory (not sure why a margin is needed)junk = SETMEM(-CLNG(memReq + 1) * 16)' Use DOS Interrupt 0x48 to request <memReq> paragraphs of memoryregs.ax = &H4800regs.bx = memReqCALL INTERRUPTX(&H21, regs, regs)' If CF is not clear, something went wrongIF (regs.flags AND &H1) THENjunk = SETMEM(650000)ELSEmemAlloc% = regs.axEND IFEND FUNCTION'''' Free memory reserved via DOS Interrupt 0x21, function 0x48''SUB memFree (segAdr AS INTEGER)DIM junk AS LONG, regs AS RegTypeX' No segment specified, abortIF (segAdr = 0) THEN EXIT SUB' Free allocated memoryregs.ax = &HA900regs.es = segAdrCALL INTERRUPTX(&H21, regs, regs)' Clear segment and offsetsegAdr = 0' Give back memory to QuickBASICjunk = SETMEM(650000)END SUB
Statistics: Posted by MikeHawk — Wed Sep 01, 2021 2:44 pm
Statistics: Posted by Erik — Wed Aug 25, 2021 2:40 pm
Statistics: Posted by MikeHawk — Sun Aug 22, 2021 11:31 am
Statistics: Posted by Anthony.R.Brown — Thu Aug 19, 2021 8:06 am
Code:
' The basics:' 1. Only when going UP (or on initialization):' > Get all folders from current directory, seek file' 2. Seek next folder we should search' > If there's a folder, enter it (going UP) and repeat all steps.' > If there's no folder left, go to parent (going DOWN), repeat all steps.' You're done when you're no longer allowed to go DOWN.'$INCLUDE: 'QB.BI'DEFINT A-ZCONST debugLevel = 1 ' set to 0 for silent, 1 for path, 2 for path & bufferDECLARE SUB searchFile (where AS STRING, query AS STRING)DECLARE SUB getObjects (where AS STRING, query AS STRING)DECLARE SUB debugBuffer ()DECLARE FUNCTION scopeDown% ()DECLARE FUNCTION scopeUp$ ()DECLARE FUNCTION scopeAppend% (folder AS STRING)DECLARE FUNCTION INSTRREV% (source AS STRING, find AS STRING)CONST moveROOT = 0CONST moveDOWN = -1CONST moveUP = 1TYPE scopeInfo ' OFS SZE DESCRIPTION start AS INTEGER ' 000 ..2 Starting offset in pathLst (starts at 1) count AS INTEGER ' 002 ..2 Number of folders visit AS INTEGER ' 004 ..2 Index of last visited folder (0 for none)END TYPE ' 6 BYTES - Scope descriptorDIM SHARED pathLst AS STRING * 20000 ' Parent and current sub-foldersDIM SHARED pathOfs AS INTEGER ' Writing offset for pathLstDIM SHARED levlNfo(0 TO 63) AS scopeInfo ' Root plus 63 levels deepDIM SHARED levlNow AS INTEGER ' How deep we are' Search for all files named "duke3d.grp" starting from "c:/games/"' Note: the program assumes more than one file can have this name; finding a' file won't stop the program. There's not user escape implemented.searchFile "c:/games/", "duke3d.grp"'''' Display folder name buffer, DEBUG PURPOSE ONLY''SUB debugBuffer DIM length AS INTEGER, offset AS INTEGER, scopeId AS INTEGER offset = 1 DO IF (offset = levlNfo(scopeId).start) THEN COLOR 1 + (scopeId AND &HF) scopeId = scopeId + 1 END IF length = ASC(MID$(pathLst, offset, 1)) PRINT MID$(pathLst, offset + 1, length); " "; offset = offset + length + 1 LOOP WHILE (offset < pathOfs) COLOR 8: PRINT pathOfsEND SUB'''' Get all objects in current directory''SUB getObjects (where AS STRING, query AS STRING) DIM DTA AS STRING * 44, MaskZ AS STRING DIM regs AS RegTypeX, objName AS STRING '' SETUP DTA SO WE DON'T DESTROY COMMAND$ '' regs.ax = &H1A00 ' Set DTA function regs.dx = VARPTR(DTA) ' DS:DX points to our DTA regs.ds = -1 ' Use current value for DS CALL INTERRUPTX(&H21, regs, regs) ' Do the interrupt MaskZ = where + "*.*" + CHR$(0) ' Mask (search all) regs.ax = &H4E00 ' FindFirst regs.cx = 16 ' Get all object types regs.dx = SADD(MaskZ) ' DS:DX points to ASCIIZ file mask regs.ds = -1 ' Use current DS '' PARSE ALL OBJECTS '' DO CALL INTERRUPTX(&H21, regs, regs) ' Do the interrupt IF (regs.flags AND &H1) THEN EXIT DO ' No object left objName = UCASE$(MID$(DTA, 31, INSTR(31, DTA, CHR$(0)) - 31)) ' Folder, append to scope IF (ASC(MID$(DTA, &H15 + 1, 1)) AND &H10) THEN IF ((objName <> ".") AND (objName <> "..")) THEN IF scopeAppend%(objName) THEN PRINT "Buffer overflow!": END END IF ' File, compare with query ELSE IF (objName = query) THEN PRINT "Found file in " + CHR$(34) + where + CHR$(34) + " there might be more! (PRESS ANY KEY)": SLEEP END IF END IF ' FindNext regs.ax = &H4F00 LOOPEND SUB'''' Last occurence of a string''FUNCTION INSTRREV% (source AS STRING, find AS STRING) DIM ofs AS INTEGER DO INSTRREV% = ofs ofs = INSTR(ofs + 1, source, find) LOOP WHILE ofsEND FUNCTION'''' Append subfolder to scope. One byte is reserved to provide the length in'' bytes of the folder name. This takes less memory than assuming that all'' folders have 12-byte long names. This function returns -1 if the memory'' buffer is saturated. Returns 0 if the sub-folder was successfully added.''FUNCTION scopeAppend% (folder AS STRING) DIM tmp AS STRING IF (levlNfo(levlNow).start = 0) THEN levlNfo(levlNow).start = pathOfs levlNfo(levlNow).count = levlNfo(levlNow).count + 1 tmp = LTRIM$(RTRIM$(UCASE$(folder))) tmp = CHR$(LEN(tmp)) + tmp IF ((pathOfs + LEN(tmp)) >= LEN(pathLst)) THEN scopeAppend% = -1 ELSE MID$(pathLst, pathOfs, LEN(tmp)) = tmp pathOfs = pathOfs + LEN(tmp) scopeAppend% = 0 END IFEND FUNCTION'''' Free current scope and go back to parent. Freeing means that we no longer'' need the sub-folder list for this scope so we can rewrite it. We also clear'' the descriptor so it can be re-used. This function returns -1 if root as'' been reached (there's no parent directory.)''FUNCTION scopeDown% IF levlNfo(levlNow).start THEN pathOfs = levlNfo(levlNow).start levlNfo(levlNow).start = 0 levlNfo(levlNow).count = 0 levlNfo(levlNow).visit = 0 scopeDown% = (levlNow = 0)END FUNCTION'''' Search for the next sub-folder in this scope we should be browsing. The'' "folder" argument returns the name of the next folder to enter (variable is'' never read, only written.) If there is no more folder to visit, "folder" is'' empty (you have to scopeDown.)''FUNCTION scopeUp$ DIM offset AS INTEGER, length AS INTEGER levlNfo(levlNow).visit = levlNfo(levlNow).visit + 1 IF (levlNfo(levlNow).visit > levlNfo(levlNow).count) THEN scopeUp$ = "" ' nothing left to see here ELSE ' get next folder in line to browse offset = levlNfo(levlNow).start FOR i% = 1 TO levlNfo(levlNow).visit length = ASC(MID$(pathLst, offset, 1)) offset = offset + length + 1 NEXT i% scopeUp$ = MID$(pathLst, offset - length, length) END IFEND FUNCTION'''' Where is the base directory (where we start looking for the file,) it must'' be an absolute path and be terminated with a forward slash ("/".) Query is'' the file name we're looking for.''SUB searchFile (where AS STRING, query AS STRING) DIM pathNxt AS STRING, pathAll AS STRING DIM move AS INTEGER pathOfs = 1 ' Always set to 1 before starting move = moveROOT ' Pretend we're moving up (for folder list) levlNow = 0 ' We start at level 0 pathAll = where query = LTRIM$(RTRIM$(UCASE$(query))) DO IF (move <> moveDOWN) THEN if (debugLevel = 1) then PRINT CHR$(34) + pathAll + CHR$(34) ' Append directories, search for file IF (move) THEN levlNow = levlNow + 1 CALL getObjects(pathAll, query) END IF if (debugLevel = 2) then CLS : PRINT CHR$(34) + pathAll + CHR$(34); TAB(75); levlNow: debugBuffer end if ' Enter next sub-directory pathNxt = scopeUp$ IF LEN(pathNxt) THEN pathAll = pathAll + pathNxt + "/" move = moveUP ELSE IF (scopeDown%) THEN EXIT DO levlNow = levlNow - 1 pathAll = LEFT$(pathAll, INSTRREV%(LEFT$(pathAll, LEN(pathAll) - 1), "/")) move = moveDOWN END IF LOOPEND SUB
Statistics: Posted by MikeHawk — Wed Aug 18, 2021 9:28 pm
Statistics: Posted by kc0nfs — Sat Aug 14, 2021 8:25 am
Statistics: Posted by kc0nfs — Sat Aug 14, 2021 8:24 am