Upload New File

Sonderuebung/SoSe2024/SU05_2024_05_15/wahrscheinlichkeitsbaum.f95

+! Implementiert einen Wahrscheinlichkeitsbaum zu einem Urnenmodell via Pointern
+! Anzahl der verschiedenen Farben und jeweiligen Kugeln ist beliebig
+! Subroutinen zum: Aufbau, Löschen, Berechnen der Wahrscheinlichkeiten
+! Desweiteren gibt es eine Rudimentäre Subroutine zur Ausgabe des Baumes
+
+! HINWEIS: Diese Lösung ist verbesserungsfähig (effizienz), funktioniert aber korrekt
+
+
+module tree_mod
+    implicit none
+
+    private
+    public :: prob_tree, balls, build_tree, delete_tree, calc_probability, output_test
+
+
+    type branch
+        integer :: number = 0
+        type(node), pointer :: next => NULL()
+    end type
+    
+    type node
+        real :: prob = 0
+        type(branch), dimension(:), allocatable :: branches
+    end type
+
+    type prob_tree
+        type(node), pointer :: root => NULL()
+    end type
+
+    type balls
+        character(20) :: colour
+        integer :: total_number = 0
+    end type
+    
+ contains
+
+ ! funktionen für arrays vom typ branch
+    function summe (aeste)
+        type(branch), dimension(:), intent(in) :: aeste
+        integer :: summe
+        integer :: i
+
+        summe = 0
+
+        do i = 1, size(aeste)
+            summe = summe + aeste(i)%number
+        end do
+
+    end function
+
+ ! rekursive Subroutinen für den Baum
+
+    subroutine build_tree (baum, kugeln)
+        type(prob_tree), intent(out) :: baum
+        type(balls), dimension(:), allocatable, intent(out) :: kugeln
+        type(node), pointer :: current => NULL()
+        integer :: n, i
+
+     ! einlesen Kugeln
+        write(*,*) "Wie viele verschiedene Farben gibt es?"
+        read(*,*) n
+
+        allocate(kugeln(n))
+
+        do i = 1, n
+            write(*,'(A,I3,A)') "Was ist Farbe ", i, "?"
+            read(*,*) kugeln(i)%colour
+
+            write(*,*) "Wie viele " // trim(kugeln(i)%colour) // " gibt es?"
+            read(*,*) kugeln(i)%total_number
+        end do
+
+      
+     ! Wurzel ausfüllen
+        allocate(baum%root)
+
+        allocate(baum%root%branches(n))
+
+        do i = 1, n
+            baum%root%branches(i)%number = kugeln(i)%total_number
+        end do
+
+        current => baum%root
+
+
+     ! rekursiver Aufruf
+        do i = 1, n ! -> i-te Kugel wird gezogen
+            call rec_build_tree(baum%root%branches(i)%next, current, n, i)
+        end do
+        
+    end subroutine build_tree
+    
+    recursive subroutine rec_build_tree (current, parent, n, i)
+        type(node), intent(inout), pointer :: current
+        type(node), intent(in), pointer :: parent
+        integer, intent(in) :: n, i
+        integer :: j
+     
+
+        allocate(current)
+        allocate(current%branches(n))
+
+     ! momentanen Ast auffüllen
+        do j = 1, n
+            current%branches(j)%number = parent%branches(j)%number
+        end do
+
+        ! i-te Kugel wurde gezogen
+        current%branches(i)%number = current%branches(i)%number - 1 
+       
+        
+     ! Rekursiv Äste einlesen, solange noch Kugeln da sind
+        do j = 1, n
+            if (current%branches(j)%number /= 0) then
+                call rec_build_tree (current%branches(j)%next, current, n, j)
+
+            elseif (current%branches(j)%number == 0) then
+                ! keine Kugeln mehr, ende der Rekursion für diesen Pfad
+            else 
+                write(*,*) "FEHLER beim Aufbau. Negative Kugelanzahl!"
+            end if
+        end do 
+
+    end subroutine rec_build_tree 
+    
+
+    subroutine delete_tree (baum)
+        type(prob_tree), intent(inout) :: baum
+        integer :: n
+
+        n = size(baum%root%branches)
+
+        call rec_delete_tree(baum%root, n)
+        
+    end subroutine delete_tree 
+
+    recursive subroutine rec_delete_tree (current, n)
+        type(node), pointer, intent(inout) :: current
+        integer, intent(in) :: n
+        integer :: i
+
+     ! Kinder löschen
+        do i = 1, n
+            if (associated(current%branches(i)%next)) then
+                ! Kind existiert
+                call rec_delete_tree(current%branches(i)%next, n)
+                current%branches(i)%next => NULL()
+            end if
+        end do
+        
+     ! Knotenpunkt löschen
+        deallocate(current%branches)
+        deallocate(current)
+        current => NULL()
+        
+    end subroutine rec_delete_tree 
+
+
+    subroutine calc_probability(baum)
+        type(prob_tree), intent(in) :: baum
+        integer :: i
+
+        baum%root%prob = 1
+      
+        do i = 1, size(baum%root%branches)
+            call rec_calc_prob(baum%root%branches(i)%next, 1., baum%root%branches(i)%number)
+        end do
+
+    end subroutine calc_probability
+
+    recursive subroutine rec_calc_prob(current, prob_parent, current_number)
+        type(node), pointer, intent(in) :: current
+        real, intent(in) :: prob_parent
+        integer, intent(in) :: current_number
+        integer :: i
+
+     ! Knotenpunkt berechen
+        current%prob = prob_parent * (real(current_number) / real((summe(current%branches) + 1)))
+
+     ! Rekursiv Kinder aufrufen und berechen   
+        do i = 1, size(current%branches)
+            if (associated(current%branches(i)%next)) then
+                ! Kind existiert
+                call rec_calc_prob(current%branches(i)%next, current%prob, current%branches(i)%number)
+            end if
+        
+        end do
+        
+    end subroutine rec_calc_prob
+
+
+    subroutine output_test(baum)
+        ! Gibt die Wahrscheinlichkeit von allen Ästen aus, bis der Weg zum 1. Mal 0% ist
+
+        type(prob_tree), intent(in) :: baum
+    
+        call rec_output(baum%root, 0)
+    end subroutine output_test
+
+    recursive subroutine rec_output(current, tief)
+        type(node), intent(in) :: current
+        integer, intent(in) :: tief
+        integer :: i, j
+
+     ! Gib 1. Hälfte der Äste aus   
+        do i = 1, int(size(current%branches)/2)
+            if (associated(current%branches(i)%next)) then
+                ! Kind existiert
+                call rec_output(current%branches(i)%next, tief + 1)
+
+            else
+                ! Leerzeichens, um die verschiedenen Ebenen des Baumes zu erhalten
+                do j = 1, (tief+1)*8
+                    write(*,'(X)', advance = "no")
+                end do
+                write(*,'(A)') "0.000%"
+            end if
+        end do
+
+     ! Gib die Wurzel aus, in der Mitte der Äste um einen ~symmetrischen Baum zu erhalten  
+        do i = 1, tief*8
+            write(*,'(X)', advance = "no")
+        end do
+        write(*,'(F5.3,"%")') current%prob
+
+     ! Gib 2. Hälfte der Äste aus   
+        do i = int(size(current%branches)/2) + 1, size(current%branches)
+            if (associated(current%branches(i)%next)) then
+                ! Kind existiert
+                call rec_output(current%branches(i)%next, tief + 1)
+
+            else
+                do j = 1, (tief+1)*8
+                    write(*,'(X)', advance = "no")
+                end do
+                write(*,'(A)') "0.000%"
+            end if
+        end do
+        
+    end subroutine rec_output
+
+
+end module tree_mod
+
+program probability
+    use tree_mod
+    implicit none
+
+    type(prob_tree) :: baum
+    type(balls), dimension(:), allocatable :: kugeln
+
+    call build_tree (baum, kugeln)
+
+    call calc_probability (baum)
+
+    call output_test (baum)
+
+    call delete_tree (baum)
+
+end program probability
\ No newline at end of file