diff --git a/Sonderuebung/SoSe2024/SU05_2024_05_15/wahrscheinlichkeitsbaum.f95 b/Sonderuebung/SoSe2024/SU05_2024_05_15/wahrscheinlichkeitsbaum.f95 new file mode 100644 index 0000000000000000000000000000000000000000..1a0ae1e39abffca8a536a6dbc6a4646ae9efa9d0 --- /dev/null +++ b/Sonderuebung/SoSe2024/SU05_2024_05_15/wahrscheinlichkeitsbaum.f95 @@ -0,0 +1,260 @@ +! 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