Upload New File

Sonderuebung/SoSe2024/SU_2024_06_11/labyrinth.f95

+! Löst ein Labyrinth (als Character Array gespeichert)
+! Start und Endpunkt liegen auf den Rändern
+! Wände sind x (die Ränder sind bis auf Start und Endpukt Wände)
+! freie Plätze sind .
+! Der Weg wird mit o markiert
+
+module labyrinth_mod
+    implicit none
+
+    private
+    public :: get, solve
+    
+ contains
+
+    subroutine get (A, start)
+        character, dimension(:,:), allocatable, intent(out) :: A
+        integer, dimension(2), intent(out) :: start
+        integer :: n, m, i, ios
+
+        write(*,*) "Wie viele Zeilen und Spalten hat das Labyrinth?"
+        do
+            read(*,*) m, n
+            if (n >= 3 .and. m >= 3) exit
+            write(*,*) "Die Werte müssen beide >= 3 sein. Erneute Eingabe:"
+        end do
+
+        write(*,*) "Was ist die Startposition? (Zeile, Spalte)"
+        read(*,*) start
+        ! hier sollte evtll noch ein test hin, ob start tatsächlich auf dem Rand liegt
+
+
+        allocate(A(m,n))
+
+        open(30, file = "lab.txt", action = "read", status = "old", iostat = ios)
+        if (ios == 0) then
+
+            do i = 1, m
+                    read(30,*) A(i,:)
+            end do
+
+        else
+            write(*,*) "Datei konnte nicht geoeffnet werden."
+        end if
+        close (30)
+
+    end subroutine get 
+
+    subroutine put (A)
+        character, dimension(:,:), intent(in) :: A
+        integer :: i
+
+        do i = 1, size(A,1) 
+            write(*,*) A(i,:)
+        end do
+    
+    end subroutine put 
+
+    subroutine solve (A, start)
+        character, dimension(:,:), intent(inout) :: A
+        integer, dimension(2), intent(in) :: start
+
+        A(start(1), start(2)) = "o"
+
+        if (start(1) == 1) then
+            call solve_rec (A, start(1) + 1, start(2)) ! erster schritt ist nach unten
+        else ! start(2) == 1
+            call solve_rec (A, start(1), start(2) + 1)
+        end if
+    
+    end subroutine solve 
+
+    recursive subroutine solve_rec (A, i,j)
+        character, dimension(:,:), intent(inout) :: A
+        integer, intent(in) :: i, j
+
+        ! Test ob Ende aka befinden wir uns gerade auf dem rand?
+        if (i == 1 .or. j == 1 .or. i == size(A,1) .or. j == size(A,2)) then
+
+            A(i,j) = "o"
+            call put(A)
+
+        else ! Prüfe die Umgebungen ob man weiter gehen kann  
+            A(i,j) = "o" 
+            if (A(i,j+1) == ".") call solve_rec (A, i,j+1) ! rechts
+            if (A(i+1,j) == ".") call solve_rec (A, i+1,j) ! unten
+            if (A(i,j-1) == ".") call solve_rec (A, i,j-1) ! links
+            if (A(i-1,j) == ".") call solve_rec (A, i-1,j) ! oben
+        end if
+
+        ! Wert wieder löschen
+        A(i,j) = "."
+        
+    end subroutine solve_rec 
+    
+end module labyrinth_mod
+
+
+program labyrinth
+    use labyrinth_mod
+    implicit none
+
+    character, dimension(:,:), allocatable :: A
+    integer, dimension(2) :: start
+
+    call get(A, start)
+    call solve (A, start)
+
+    deallocate(A)
+    
+end program labyrinth
\ No newline at end of file