Поиск кратчайшего пути

DECLARE SUB GRID ()
DECLARE SUB HELP ()
DECLARE SUB RESETWAY ()
DECLARE SUB DRAWWAY ()
DECLARE SUB BREAK ()
DECLARE SUB ROUTE (S AS INTEGER, F AS INTEGER)
DECLARE SUB CREATEMAP (P AS INTEGER)
DECLARE SUB DRAWCELL (CELL AS INTEGER)
DECLARE SUB DRAWMAP (S AS INTEGER, F AS INTEGER)
DECLARE SUB RESETMAS ()
DECLARE SUB LOADMOUSEDRV ()
DECLARE SUB MOUSEDRV (Func AS INTEGER)
 
DECLARE FUNCTION GETX% (CELL AS INTEGER)
DECLARE FUNCTION GETY% (CELL AS INTEGER)
DECLARE FUNCTION PAUSE% (P AS INTEGER)
 
TYPE MOUSESTATE
    B AS INTEGER
    X AS INTEGER
    Y AS INTEGER
END TYPE
 
TYPE CELL
    X AS INTEGER
    Y AS INTEGER
END TYPE
 
DIM SHARED MOUSECODE AS STRING, MOUSE AS MOUSESTATE
DIM S AS INTEGER, F AS INTEGER, P AS INTEGER
DIM SHARED MASX AS INTEGER, MASY AS INTEGER
REDIM SHARED B(0) AS INTEGER
 
RANDOMIZE TIMER
SCREEN 12
LOADMOUSEDRV
MASX = 40
MASY = 29
REDIM SHARED A(1, MASX - 1, MASY - 1)
REDIM B(0) AS INTEGER
S = -1
F = -1
RESETMAS
GRID
HELP
MOUSEDRV 1
DO WHILE INKEY$ <> CHR$(27)
    MOUSEDRV 3
    X = INT(MOUSE.X / 16)
    Y = INT(MOUSE.Y / 16)
    IF Y > 0 THEN
        COLOR 15
        LOCATE 1, 45: PRINT "X = "; X
        LOCATE 1, 55: PRINT "Y = "; Y - 1
        LOCATE 1, 67: PRINT RIGHT$("000" + LTRIM$(STR$(UBOUND(B))), 4);
    END IF
    IF MOUSE.B > 0 THEN
        MOUSEDRV 2
        IF MOUSE.B = 1 THEN
            IF Y = 0 THEN
                X = INT(MOUSE.X / 8)
                SELECT CASE X
                CASE IS < 3
                    IF S > -1 AND F > -1 THEN
                        RESETWAY
                        RESETMAS
                        ROUTE S, F
                        DRAWWAY
                    END IF
                CASE IS < 4
                CASE IS < 9
                    M = 0
                CASE IS < 10
                CASE IS < 14
                    REDIM SHARED A(1, MASX - 1, MASY - 1)
                    REDIM B(0) AS INTEGER
                    S = -1
                    F = -1
                    CREATEMAP 30
                    DRAWMAP S, F
                CASE IS < 15
                CASE IS < 20
                    REDIM SHARED A(1, MASX - 1, MASY - 1)
                    REDIM B(0) AS INTEGER
                    S = -1
                    F = -1
                    DRAWMAP S, F
                CASE IS < 21
                CASE IS < 26
                    M = 1
                CASE IS < 27
                CASE IS < 33
                    M = 2
                CASE IS < 34
                CASE IS < 38
                    HELP
                    DRAWMAP S, F
                    DRAWWAY
                CASE IS > 75
                    EXIT DO
                END SELECT
            ELSE
                SELECT CASE M
                CASE 0
                    A(0, X, Y - 1) = 2
                    LINE (X * 16 + 1, Y * 16 + 1)-(X * 16 + 15, Y * 16 + 15), 7, BF
                CASE 1
                    IF A(0, X, Y - 1) < 2 THEN
                        LINE (GETX(S) * 16 + 1, GETY(S) * 16 + 17)-(GETX(S) * 16 + 15, GETY(S) * 16 + 31), 0, BF
                        S = (Y - 1) * MASX + X
                        CIRCLE (X * 16 + 8, Y * 16 + 8), 5, 14
                        PAINT (X * 16 + 8, Y * 16 + 8), 14
                        B(0) = S
                    END IF
                CASE 2
                    IF A(0, X, Y - 1) < 2 THEN
                        LINE (GETX(F) * 16 + 1, GETY(F) * 16 + 17)-(GETX(F) * 16 + 15, GETY(F) * 16 + 31), 0, BF
                        F = (Y - 1) * MASX + X
                        CIRCLE (X * 16 + 8, Y * 16 + 8), 5, 10
                        PAINT (X * 16 + 8, Y * 16 + 8), 10
                        B(UBOUND(B)) = F
                    END IF
                END SELECT
            END IF
        ELSEIF MOUSE.B = 2 THEN
            IF Y > 0 THEN
                A(0, X, Y - 1) = 0
                LINE (X * 16 + 1, Y * 16 + 1)-(X * 16 + 15, Y * 16 + 15), 0, BF
            END IF
        END IF
        MOUSEDRV 1
    END IF
LOOP
CLS
SYSTEM
 
SUB CREATEMAP (P AS INTEGER)
    DIM N AS INTEGER, X AS INTEGER, Y AS INTEGER, C AS INTEGER
    N = INT((MASX * MASY) * (P / 100))
    DO WHILE N > 0
       X = INT(RND * (MASX))
       Y = INT(RND * (MASY))
       IF A(0, X, Y) = 0 THEN
            A(0, X, Y) = 2
            N = N - 1
       END IF
    LOOP
END SUB
 
SUB DRAWMAP (S AS INTEGER, F AS INTEGER)
    FOR Y = 0 TO MASY - 1
        FOR X = 0 TO MASX - 1
            IF A(0, X, Y) = 2 THEN
                LINE (X * 16 + 1, Y * 16 + 17)-(X * 16 + 15, Y * 16 + 31), 7, BF
            ELSE
                LINE (X * 16 + 1, Y * 16 + 17)-(X * 16 + 15, Y * 16 + 31), 0, BF
            END IF
        NEXT X
    NEXT Y
END SUB
 
SUB DRAWWAY
    DIM I AS INTEGER
    IF UBOUND(B) > 0 THEN
        FOR I = 1 TO UBOUND(B)
            X = GETX(B(I))
            Y = GETY(B(I))
            X1 = GETX(B(I - 1))
            Y1 = GETY(B(I - 1))
            LINE (X * 16 + 1, Y * 16 + 17)-(X * 16 + 14, Y * 16 + 30), 0, BF
            LINE (X1 * 16 + 8, Y1 * 16 + 24)-(X * 16 + 8, Y * 16 + 24), 11
            CIRCLE (X * 16 + 8, Y * 16 + 24), 2, 11
            IF I = 1 THEN
                CIRCLE (X1 * 16 + 8, Y1 * 16 + 24), 5, 14
                PAINT (X1 * 16 + 8, Y1 * 16 + 24), 14
            END IF
        NEXT I
        CIRCLE (X * 16 + 8, Y * 16 + 24), 5, 10
        PAINT (X * 16 + 8, Y * 16 + 24), 10
    END IF
    COLOR 15: LOCATE 1, 67: PRINT RIGHT$("000" + LTRIM$(STR$(UBOUND(B))), 4);
END SUB
 
FUNCTION GETX% (CELL AS INTEGER)
    GETX = CELL MOD MASX
END FUNCTION
 
FUNCTION GETY% (CELL AS INTEGER)
    GETY = INT(CELL / MASX)
END FUNCTION
 
SUB GRID
    DIM X AS INTEGER, Y AS INTEGER, C AS INTEGER
    COLOR 12: LOCATE 1, 1: PRINT "RUN"
    COLOR 10: LOCATE 1, 5: PRINT "BLOCK AUTO RESET START FINISH HELP"
    COLOR 12: LOCATE 1, 77: PRINT "EXIT"
    LINE (0, 0 + 16)-(639, 479), 0, BF
    FOR X = 0 TO MASX
        LINE (0, 0 + 16)-(X * 16, MASY * 16 + 16), 8, B
    NEXT X
    FOR Y = 0 TO MASY
        LINE (0, 0 + 16)-(MASX * 16, Y * 16 + 16), 8, B
    NEXT Y
END SUB
 
SUB HELP
    LINE (80, 120)-(560, 375), 9, BF
    LINE (90, 130)-(550, 365), 0, BF
    COLOR 7
    LOCATE 10, 16: PRINT "Нахождение кратчайшего пути по алгоритму Дейкстры"
    LOCATE 12, 16: PRINT "1. Рисуем лабиринт в ручную [BLOCK] или генерируем"
    LOCATE 13, 19: PRINT "автоматически [AUTO]"
    LOCATE 14, 16: PRINT "1.1. Левой кнопкой ставим блоки, правой удаляем."
    LOCATE 15, 16: PRINT "1.2. Очистить поле от всех блоков [RESET]"
    LOCATE 16, 16: PRINT "2. Отмечаем стартовую точку [START]"
    LOCATE 17, 16: PRINT "3. Отмечаем точку назначения [FINISH]"
    LOCATE 18, 16: PRINT "4. Для начала расчета нажимаем [RUN]"
    LOCATE 19, 16: PRINT "5. Для получения справки нажмите [HELP]"
    LOCATE 20, 16: PRINT "6. Для выхода из программы нажмите [EXIT]"
    LOCATE 22, 22: PRINT "Для продолжения нажмите любую клавишу"
    DO WHILE INKEY$ = "": LOOP
    GRID
END SUB
 
SUB LOADMOUSEDRV
    DIM ADR AS INTEGER
    MOUSECODE = STRING$(23, CHR$(0))
    DEF SEG = VARSEG(MOUSECODE)
    ADR = SADD(MOUSECODE)
    POKE ADR, 184
    POKE ADR + 1, 0
    POKE ADR + 2, 0
    POKE ADR + 3, 205
    POKE ADR + 4, 51
    POKE ADR + 5, 137
    POKE ADR + 6, 30
    POKE ADR + 7, 0
    POKE ADR + 8, 0
    POKE ADR + 9, 137
    POKE ADR + 10, 14
    POKE ADR + 11, 0
    POKE ADR + 12, 0
    POKE ADR + 13, 137
    POKE ADR + 14, 22
    POKE ADR + 15, 0
    POKE ADR + 16, 0
    POKE ADR + 17, 203
    DEF SEG
END SUB
 
SUB MOUSEDRV (Func AS INTEGER)
    'Func = 1 - Показать курсор мыши
    'Func = 2 - Скрыть курсор мыши
    'Func = 3 - Получение позиции и состояния кнопок мыши
    DIM ADR AS INTEGER
    DEF SEG = VARSEG(MOUSECODE)
    ADR = SADD(MOUSECODE)
    POKE ADR + 1, Func
    POKE ADR + 7, (ADR + 22) MOD 256
    POKE ADR + 8, INT((ADR + 22) / 256)
    POKE ADR + 11, (ADR + 18) MOD 256
    POKE ADR + 12, INT((ADR + 18) / 256)
    POKE ADR + 15, (ADR + 20) MOD 256
    POKE ADR + 16, INT((ADR + 20) / 256)
    CALL ABSOLUTE(ADR)
    IF Func = 3 THEN
        MOUSE.X = PEEK(ADR + 18) + PEEK(ADR + 19) * 256
        MOUSE.Y = PEEK(ADR + 20) + PEEK(ADR + 21) * 256
        MOUSE.B = PEEK(ADR + 22)
    END IF
    DEF SEG
END SUB
 
SUB RESETMAS
    DIM X AS INTEGER, Y AS INTEGER, S AS INTEGER
    S = MASX ^ 2 + MASY ^ 2
    FOR Y = 0 TO MASY - 1
        FOR X = 0 TO MASX - 1
            A(1, X, Y) = S
            IF A(0, X, Y) = 1 THEN
                A(0, X, Y) = 0
            END IF
        NEXT X
    NEXT Y
    REDIM B(0) AS INTEGER
END SUB
 
SUB RESETWAY
    DIM I AS INTEGER
    IF UBOUND(B) > 0 THEN
        FOR I = 0 TO UBOUND(B)
            X = GETX(B(I))
            Y = GETY(B(I))
            LINE (X * 16, Y * 16 + 16)-(X * 16 + 16, Y * 16 + 32), 8, B
            LINE (X * 16 + 1, Y * 16 + 17)-(X * 16 + 15, Y * 16 + 31), 0, BF
            IF I = 0 THEN
                CIRCLE (X * 16 + 8, Y * 16 + 24), 5, 14
                PAINT (X * 16 + 8, Y * 16 + 24), 14
            END IF
        NEXT I
        CIRCLE (X * 16 + 8, Y * 16 + 24), 5, 10
        PAINT (X * 16 + 8, Y * 16 + 24), 10
    END IF
    COLOR 15: LOCATE 1, 67: PRINT "0000";
END SUB
 
SUB ROUTE (S AS INTEGER, F AS INTEGER)
    DIM X AS INTEGER, Y AS INTEGER, X1 AS INTEGER, Y1 AS INTEGER
    DIM I  AS INTEGER, J AS INTEGER, N AS INTEGER, K AS INTEGER, C AS INTEGER
    DIM K1 AS LONG, K2 AS LONG
    REDIM CELLS(MASX * MASY) AS CELL
    A(1, GETX(F), GETY(F)) = 0
    N = 0: J = 0
    CELLS(0).X = GETX(F)
    CELLS(0).Y = GETY(F)
    DO WHILE J <= N
        X = CELLS(J).X
        Y = CELLS(J).Y
        C = Y * MASX + X
        IF S = C THEN EXIT DO
        I = A(1, X, Y) + 1
        A(0, X, Y) = 1
        Y1 = Y - 1
        'Клетка сверху
        IF Y1 > -1 THEN
            IF A(0, X, Y1) = 0 THEN
                IF A(1, X, Y1) > I THEN
                    N = N + 1
                    CELLS(N).X = X
                    CELLS(N).Y = Y1
                    A(1, X, Y1) = I
                END IF
            END IF
        END IF
        'Клетка слева
        X1 = X - 1
        IF X1 > -1 THEN
            IF A(0, X1, Y) = 0 THEN
                IF A(1, X1, Y) > I THEN
                    N = N + 1
                    CELLS(N).X = X1
                    CELLS(N).Y = Y
                    A(1, X1, Y) = I
                END IF
            END IF
        END IF
        'Клетка справа
        X1 = X + 1
        IF X1 < MASX THEN
            IF A(0, X1, Y) = 0 THEN
                IF A(1, X1, Y) > I THEN
                    N = N + 1
                    CELLS(N).X = X1
                    CELLS(N).Y = Y
                    A(1, X1, Y) = I
                END IF
            END IF
        END IF
        'Клетка снизу
        Y1 = Y + 1
        IF Y1 < MASY THEN
            IF A(0, X, Y1) = 0 THEN
                IF A(1, X, Y1) > I THEN
                    N = N + 1
                    CELLS(N).X = X
                    CELLS(N).Y = Y1
                    A(1, X, Y1) = I
                END IF
            END IF
        END IF
        J = J + 1
    LOOP
    'Построение пути
    IF J <= N THEN
        J = A(1, GETX(S), GETY(S))
        REDIM B(J) AS INTEGER
        B(0) = S
        FOR N = 1 TO J
            REDIM CELLS(3) AS CELL
            X = GETX(B(N - 1))
            Y = GETY(B(N - 1))
            Y1 = Y - 1
            CELLS(0).X = -1
            IF Y1 > -1 THEN
                IF A(0, X, Y1) = 1 THEN
                    CELLS(0).X = Y1 * MASX + X
                    CELLS(0).Y = A(1, X, Y1)
                END IF
            END IF
            X1 = X - 1
            CELLS(1).X = -1
            IF X1 > -1 THEN
                IF A(0, X1, Y) = 1 THEN
                    CELLS(1).X = Y * MASX + X1
                    CELLS(1).Y = A(1, X1, Y)
                END IF
            END IF
            X1 = X + 1
            CELLS(2).X = -1
            IF X1 < MASX THEN
                IF A(0, X1, Y) = 1 THEN
                    CELLS(2).X = Y * MASX + X1
                    CELLS(2).Y = A(1, X1, Y)
                END IF
            END IF
            Y1 = Y + 1
            CELLS(3).X = -1
            IF Y1 < MASY THEN
                IF A(0, X, Y1) = 1 THEN
                    CELLS(3).X = Y1 * MASX + X
                    CELLS(3).Y = A(1, X, Y1)
                END IF
            END IF
            K = MASX * MASY
            FOR I = 0 TO 3
                IF CELLS(I).X > -1 THEN
                    IF K > CELLS(I).Y THEN
                        C = CELLS(I).X
                        K = CELLS(I).Y
                    ELSEIF K = CELLS(I).Y THEN
                        'Рандомим для получения вариаций если есть несколько вариантов
                        IF INT(RND * 2) > 0 THEN
                            C = CELLS(I).X
                            K = CELLS(I).Y
                        END IF
                    END IF
                END IF
            NEXT I
            B(N) = C
        NEXT N
    END IF
    SOUND 500, .5
END SUB