Query.hs

{-# LANGUAGE BangPatterns #-}
{-# OPTIONS_GHC -Wno-orphans #-}
{-# OPTIONS_GHC -Wno-type-defaults #-}

module Zwirn.Core.Query where

{-
    Query.hs - querying signals for breakpoints
    (i.e. the zeroes of the fractional part of the inner time of a signal)
    Copyright (C) 2025, Martin Gius

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

    This library 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 General Public License for more details.

    You should have received a copy of the GNU General Public License
    along with this library.  If not, see <http://www.gnu.org/licenses/>.
-}

import Data.List (uncons)
import Zwirn.Core.Time
import Zwirn.Core.Tree hiding (concat)
import Zwirn.Core.Types

type Breakpoint st i a = (Time, Value i a, st)

instance (Show a, Num st, ToList k) => Show (ZwirnT k st i a) where
  show = show . findAllValuesWithTime (Time 0 1, Time 1 1) 0

findAllValuesWithTime :: (ToList k) => (Time, Time) -> st -> ZwirnT k st i a -> [(Time, a)]
findAllValuesWithTime = findAllValuesWithTimePrec 0.005

findAllValuesWithTimeState :: (ToList k) => (Time, Time) -> st -> ZwirnT k st i a -> ([(Time, a)], st)
findAllValuesWithTimeState = findAllValuesWithTimeStatePrec 0.005

findAllValuesWithTimePrec :: (ToList k) => Time -> (Time, Time) -> st -> ZwirnT k st i a -> [(Time, a)]
findAllValuesWithTimePrec prec (start, end) st z = map (\(t, v, _) -> (t, value v)) xs
  where
    (xs, _) = findAllBreakpoints prec start end st z

findAllValuesWithTimeStatePrec :: (ToList k) => Time -> (Time, Time) -> st -> ZwirnT k st i a -> ([(Time, a)], st)
findAllValuesWithTimeStatePrec prec (start, end) st z = (map (\(t, v, _) -> (t, value v)) xs, st')
  where
    (xs, st') = findAllBreakpoints prec start end st z

checkBreakpoint :: (ToList k) => Time -> Time -> st -> ZwirnT k st i a -> ([Breakpoint st i a], st)
checkBreakpoint !prec !now st z = (concatMap func vs, newst)
  where
    vs = toList $ unzwirn z now st
    func (v, _) = [(now, v, st) | breakpointCondition prec (time v)]
    newst = case uncons vs of
      (Just ((_, st'), _)) -> st'
      Nothing -> st

breakpointCondition :: Time -> Time -> Bool
breakpointCondition prec (Time !t !diff)
  | diff > 0 = frac t / diff < tTime prec
  | diff == 0 = False
  | otherwise = frac (abs t) / abs diff < tTime prec

findAllBreakpoints :: (ToList k) => Time -> Time -> Time -> st -> ZwirnT k st i a -> ([Breakpoint st i a], st)
findAllBreakpoints prec !now end initialSt z = go [] now initialSt
  where
    !limit = end - prec
    go acc !t !st
      | t > limit = (reverse acc, st)
      | otherwise = case checkBreakpoint prec t st z of
          ([], st') -> go acc (t + prec) st'
          (bps, newst) -> go (reverse bps ++ acc) (t + prec) newst