!    Program for playing melodyes on PC-Speaker.
!    For GNU/Linux 64 bit version.
!    Version: 4.
!    Written on FreePascal (https://freepascal.org/).
!    Copyright (C) 2021-2026  Artyomov Alexander
!    http://self-made-free.ru/
!    aralni@mail.ru

!    This program is free software: you can redistribute it and/or modify
!    it under the terms of the GNU Affero General Public License as
!    published by the Free Software Foundation, either version 3 of the
!    License, or (at your option) any later version.

!    This program is distributed in the hope that it will be useful,
!    but WITHOUT ANY WARRANTY; without even the implied warranty of
!    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
!    GNU Affero General Public License for more details.

!    You should have received a copy of the GNU Affero General Public License
!    along with this program.  If not, see <https://www.gnu.org/licenses/>.

! gfortran -fPIE -pie -O4 -msse4a -ffast-math -fforce-addr -funroll-loops gorg64_spkplay.f90 -o gorg64_spkplay

program gorg64_spkplay
    use, intrinsic :: iso_c_binding
    implicit none
    
    ! Константы
    integer :: i, argc, fd, f_uid, f_euid
    integer :: pid, stat_result
    integer :: f, ff, file_size
    character(len=256) :: arg
    character(len=256), dimension(:), allocatable :: args
    logical :: already_running = .false.
    integer :: system_result
    integer :: port_dev
    logical :: playing = .false.
    
    ! Тип для данных мелодии
    type :: ttw_type
        integer(2) :: tone      ! Значение для отправки в порт (готовый делитель)
        integer(2) :: duration  ! Длительность в мс
    end type ttw_type
    
    type(ttw_type), dimension(:), allocatable, target :: melody_data
    
    ! Интерфейсы к системным вызовам
    interface
        function getuid() bind(c, name="getuid")
            use iso_c_binding
            integer(c_int) :: getuid
        end function getuid
        
        function geteuid() bind(c, name="geteuid")
            use iso_c_binding
            integer(c_int) :: geteuid
        end function geteuid

        function setuid(uid) bind(c, name="setuid")
            use iso_c_binding
            integer(c_int), value :: uid
            integer(c_int) :: setuid
        end function setuid
        
        function getpid() bind(c, name="getpid")
            use iso_c_binding
            integer(c_int) :: getpid
        end function getpid
        
        subroutine usleep(microseconds) bind(c, name="usleep")
            use iso_c_binding
            integer(c_int), value :: microseconds
        end subroutine usleep
        
        function open_file(path, flags) bind(c, name="open")
            use iso_c_binding
            character(c_char), intent(in) :: path(*)
            integer(c_int), value :: flags
            integer(c_int) :: open_file
        end function open_file
        
        function close_file(fd) bind(c, name="close")
            use iso_c_binding
            integer(c_int), value :: fd
            integer(c_int) :: close_file
        end function close_file
        
        function read_file(fd, buf, count) bind(c, name="read")
            use iso_c_binding
            integer(c_int), value :: fd
            type(c_ptr), value :: buf
            integer(c_int), value :: count
            integer(c_int) :: read_file
        end function read_file
        
        function write_file(fd, buf, count) bind(c, name="write")
            use iso_c_binding
            integer(c_int), value :: fd
            type(c_ptr), value :: buf
            integer(c_int), value :: count
            integer(c_int) :: write_file
        end function write_file
        
        function lseek_file(fd, offset, whence) bind(c, name="lseek")
            use iso_c_binding
            integer(c_int), value :: fd
            integer(c_int), value :: offset
            integer(c_int), value :: whence
            integer(c_int) :: lseek_file
        end function lseek_file
        
        function killall(cmd) bind(c, name="system")
            use iso_c_binding
            character(c_char), intent(in) :: cmd(*)
            integer(c_int) :: killall
        end function killall
        
        function signal(sig, handler) bind(c, name="signal")
            use iso_c_binding
            integer(c_int), value :: sig
            type(c_funptr), value :: handler
            type(c_funptr) :: signal
        end function signal
    end interface
    
    ! Внешняя функция-обработчик сигналов
    interface
        subroutine signal_handler(sig) bind(c)
            use iso_c_binding
            integer(c_int), value :: sig
        end subroutine signal_handler
    end interface
    
    ! Вывод информации о программе
    write(*,'(A)') 'GALAXY ORGANIZER SPEAKER PLAYER Fortran Version (/dev/port)'
    write(*,'(A)') 'Based on original C/Pascal version by Artyomov Alexander'
    write(*,'(A)') 'Use: gorg64_spkplay or gorg64_spkplay file1.speaker file2.speaker ...'
    
    ! Получение UID и EUID
    f_uid = getuid()
    f_euid = geteuid()
    write(*,'(A,I0,A,I0)') 'UID=', f_uid, ' EUID=', f_euid

    ! Попытка установить UID если EUID=0
    if (f_euid == 0) then
        if (setuid(0) /= 0) then
            write(*,'(A)') 'Error set UID'
        end if
    end if
    
    f_uid = getuid()
    write(*,'(A,I0,A,I0)') 'Now UID=', f_uid
    
    if (f_euid /= 0) then
        write(*,'(A)') 'Ошибка: Требуются права root! Используйте:'
        write(*,'(A)') 'sudo ./gorg64_spkplay файлы.speaker'
        call exit(1)
    end if
    
    ! Получение аргументов командной строки
    argc = command_argument_count()
    
    ! Проверка на --stop
    if (argc >= 1) then
        call get_command_argument(1, arg)
        if (trim(arg) == '--stop') then
            system_result = killall(c_char_'pkill -f gorg64_spkplay'//c_null_char)
            call exit(0)
        end if
    end if
    
    ! Проверка, не запущена ли уже программа
    pid = getpid()
    call check_already_running(pid, already_running)
    if (already_running) then
        write(*,'(A)') 'Already running. Exit.'
        call exit(0)
    end if
    
    ! Установка обработчиков сигналов
    call install_signal_handlers()
    
    ! Установка приоритета
    call set_priority(-20)
    
    ! Открытие /dev/port
    port_dev = open_file(c_char_'/dev/port'//c_null_char, int(2, c_int)) ! O_RDWR
    if (port_dev < 0) then
        write(*,'(A)') 'Ошибка: Не удалось открыть /dev/port'
        write(*,'(A)') 'Требуются права root!'
        call exit(1)
    end if
    write(*,'(A)') '✓ Инициализация динамика успешна'
    
    ! Если нет аргументов - проигрываем тестовый звук
    if (argc == 0) then
        call play_test_sound(port_dev)
        stat_result = close_file(int(port_dev, c_int))
        call exit(0)
    end if
    
    ! Выделение памяти под аргументы
    allocate(args(argc))
    do i = 1, argc
        call get_command_argument(i, args(i))
    end do
    
    ! Проигрывание всех указанных файлов
    do ff = 1, argc
        write(*,'(A)') trim(args(ff))
        
        ! Загрузка файла
        call load_melody_file(trim(args(ff)), melody_data, file_size, stat_result)
        if (stat_result /= 0) then
            write(*,'(A,I0)') 'Ошибка загрузки файла, код=', stat_result
            call play_error_sound(port_dev)
            cycle
        end if
        
        ! Проигрывание мелодии
        call play_melody(port_dev, melody_data, file_size)
        
        ! Освобождение памяти
        if (allocated(melody_data)) deallocate(melody_data)
    end do
    
    stat_result = close_file(int(port_dev, c_int))
    call exit(0)
    
contains

    ! Обработчик сигналов
    subroutine signal_handler_int(sig) bind(c)
        integer(c_int), value :: sig
        write(*,'(A,I0)') 'Получен сигнал ', sig
        call safe_spkoff()
        call exit(1)
    end subroutine signal_handler_int
    
    ! Безопасное выключение динамика
    subroutine safe_spkoff()
        if (port_dev >= 0 .and. playing) then
            call spk_off(port_dev)
            playing = .false.
        end if
    end subroutine safe_spkoff
    
    ! Установка обработчиков сигналов
    subroutine install_signal_handlers()
        type(c_funptr) :: ret
        
        ! SIGTERM
        ret = signal(int(15, c_int), c_funloc(signal_handler_int))
        ! SIGINT (Ctrl+C)
        ret = signal(int(2, c_int), c_funloc(signal_handler_int))
        ! SIGHUP
        ret = signal(int(1, c_int), c_funloc(signal_handler_int))
        ! SIGQUIT
        ret = signal(int(3, c_int), c_funloc(signal_handler_int))
        
        write(*,'(A)') '✓ Обработчики сигналов установлены'
    end subroutine install_signal_handlers
    
    subroutine outb(dev_fd, port, value)
        integer, intent(in) :: dev_fd
        integer(2), intent(in) :: port
        integer(1), intent(in) :: value
        
        integer(c_int) :: result
        integer(c_int) :: status
        character(len=1), target :: buf
        
        buf = char(value)
        status = lseek_file(int(dev_fd, c_int), int(port, c_int), int(0, c_int)) ! SEEK_SET
        if (status < 0) then
            write(*,'(A,I0)') 'outb: lseek error ', status
            return
        end if
        result = write_file(int(dev_fd, c_int), c_loc(buf), int(1, c_int))
    end subroutine outb
    
    function inb(dev_fd, port) result(value)
        integer, intent(in) :: dev_fd
        integer(2), intent(in) :: port
        integer(1) :: value
        
        integer(c_int) :: status
        character(len=1), target :: buf
        
        status = lseek_file(int(dev_fd, c_int), int(port, c_int), int(0, c_int)) ! SEEK_SET
        if (status < 0) then
            value = 0
            return
        end if
        status = read_file(int(dev_fd, c_int), c_loc(buf), int(1, c_int))
        if (status > 0) then
            value = ichar(buf(1:1))
        else
            value = 0
        end if
    end function inb
    
    subroutine check_already_running(current_pid, running)
        integer, intent(in) :: current_pid
        logical, intent(out) :: running
        integer :: status
        character(len=100) :: cmd
        
        running = .false.
        
        ! Используем pgrep для поиска процессов с именем gorg64_spkplay
        ! Исключаем текущий процесс по PID
        write(cmd, '(A,I0,A)') 'pgrep -x gorg64_spkplay | grep -v ', current_pid, ' > /dev/null 2>&1'
        call execute_command_line(cmd, wait=.true., exitstat=status)
        
        if (status == 0) then
            running = .true.
            write(*,'(A)') 'Найден другой запущенный процесс'
        end if
        
    end subroutine check_already_running
    
    subroutine set_priority(prio)
        integer, intent(in) :: prio
        character(len=100) :: cmd_str
        
        write(cmd_str, '(A,I0,A,I0)') 'renice -n ', prio, ' -p ', getpid()
        call execute_command_line(cmd_str, wait=.true.)
    end subroutine set_priority
    
    ! Включение PC-спикера
    subroutine spk_on(dev_fd)
        integer, intent(in) :: dev_fd
        integer(1) :: tmp
        
        tmp = inb(dev_fd, int(z'61', 2))
        tmp = ior(tmp, int(3, 1))
        call outb(dev_fd, int(z'61', 2), tmp)
    end subroutine spk_on
    
    ! Выключение PC-спикера
    subroutine spk_off(dev_fd)
        integer, intent(in) :: dev_fd
        integer(1) :: tmp
        
        tmp = inb(dev_fd, int(z'61', 2))
        tmp = iand(tmp, int(z'FC', 1))
        call outb(dev_fd, int(z'61', 2), tmp)
    end subroutine spk_off
    
    ! Прямая установка делителя частоты (значение уже готово из файла .speaker)
    subroutine spk_set_divider(dev_fd, divider)
        integer, intent(in) :: dev_fd
        integer(2), intent(in) :: divider
        
        if (divider <= 0) return
        
        call outb(dev_fd, int(z'43', 2), int(z'B6', 1))
        call outb(dev_fd, int(z'42', 2), int(iand(divider, int(z'FF', 2)), 1))
        call outb(dev_fd, int(z'42', 2), int(iand(ishft(divider, -8), int(z'FF', 2)), 1))
    end subroutine spk_set_divider
    
    ! Загрузка файла мелодии
    subroutine load_melody_file(filename, data, fsize, status)
        character(len=*), intent(in) :: filename
        type(ttw_type), dimension(:), allocatable, target, intent(out) :: data
        integer, intent(out) :: fsize
        integer, intent(out) :: status
        
        integer :: fd
        integer(c_int) :: bytes_read
        type(c_ptr) :: buf_ptr
        integer(c_int) :: file_len
        integer(c_int) :: seek_result
        
        status = 0
        fd = open_file(trim(filename)//c_null_char, int(0, c_int)) ! O_RDONLY
        if (fd < 0) then
            write(*,'(A,I0)') 'Ошибка открытия файла, fd=', fd
            status = -1
            return
        end if
        
        ! Получаем размер файла - переходим в конец
        file_len = lseek_file(int(fd, c_int), int(0, c_int), int(2, c_int)) ! SEEK_END
        if (file_len < 0) then
            write(*,'(A)') 'Ошибка lseek (END)'
            status = close_file(int(fd, c_int))
            status = -2
            return
        end if
        
        write(*,'(A,I0,A)') 'File size: ', file_len, ' bytes'
        
        ! Проверяем, что размер кратен 4
        if (mod(file_len, 4) /= 0) then
            write(*,'(A)') 'Ошибка: размер файла не кратен 4'
            status = close_file(int(fd, c_int))
            status = -3
            return
        end if
        
        fsize = file_len / 4
        write(*,'(A,I0)') 'Records: ', fsize
        
        ! Возвращаемся в начало файла
        seek_result = lseek_file(int(fd, c_int), int(0, c_int), int(0, c_int)) ! SEEK_SET
        if (seek_result < 0) then
            write(*,'(A)') 'Ошибка lseek (SET)'
            status = close_file(int(fd, c_int))
            status = -4
            return
        end if
        
        ! Выделяем память и читаем данные
        allocate(data(fsize))
        buf_ptr = c_loc(data(1))
        bytes_read = read_file(int(fd, c_int), buf_ptr, int(file_len, c_int))
        
        if (bytes_read /= file_len) then
            write(*,'(A,I0,A,I0)') 'Предупреждение: прочитано ', bytes_read, ' из ', file_len, ' байт'
        end if
        
        status = close_file(int(fd, c_int))
        
    end subroutine load_melody_file
    
    ! Проигрывание мелодии
    subroutine play_melody(dev_fd, data, fsize)
        integer, intent(in) :: dev_fd
        type(ttw_type), dimension(:), intent(in) :: data
        integer, intent(in) :: fsize
        
        integer :: i
        
        write(*,'(A,I0,A)') 'Playing ', fsize, ' notes...'
        
        do i = 1, fsize
            if (data(i)%duration < 1) cycle
            
            if (data(i)%tone < 1) then
                ! Пауза
                playing = .false.
                call usleep(int(data(i)%duration * 1000, c_int))
            else
                ! Воспроизведение ноты - tone уже содержит готовый делитель
                playing = .true.
                call spk_set_divider(dev_fd, data(i)%tone)
                call spk_on(dev_fd)
                call usleep(int(data(i)%duration * 1000, c_int))
                call spk_off(dev_fd)
                playing = .false.
            end if
        end do
        
        write(*,'(A)') 'Finished playing'
        
    end subroutine play_melody
    
    ! Тестовый звук
    subroutine play_test_sound(dev_fd)
        integer, intent(in) :: dev_fd
        integer(2) :: test_divider
        
        ! 1000 Hz -> 1193182/1000 = 1193
        test_divider = int(1193, 2)
        write(*,'(A)') 'Playing test sound: 1000 Hz for 1 second'
        playing = .true.
        call spk_set_divider(dev_fd, test_divider)
        call spk_on(dev_fd)
        call usleep(int(1000000, c_int))
        call spk_off(dev_fd)
        playing = .false.
    end subroutine play_test_sound
    
    ! Звук ошибки
    subroutine play_error_sound(dev_fd)
        integer, intent(in) :: dev_fd
        integer(2) :: error_divider
        
        ! 300 Hz -> 1193182/300 = 3977
        error_divider = int(3977, 2)
        write(*,'(A)') 'Playing error sound: 300 Hz for 1 second'
        playing = .true.
        call spk_set_divider(dev_fd, error_divider)
        call spk_on(dev_fd)
        call usleep(int(1000000, c_int))
        call spk_off(dev_fd)
        playing = .false.
    end subroutine play_error_sound

end program gorg64_spkplay