This is an example of Applicative on a Profunctor.

ApplicativeProfunctor.fsx

open System


// this is our basis to define values over time.
// It will be the basis for our data.
// we define a Period with a start and en Time
// start is included, end is excluded (closed on the left, open on the right)
// this way, of consecutive periods px and py we known that px.End = py.Start
type Period = { Start: DateTime; End: DateTime }

module Period =
    let isEmpty p = p.Start <= p.End

let (=>) s e = { Start = s; End = e} // this is a short cut to define periods start => end
// pretty printer for periods
fsi.AddPrinter<Period>(fun p -> sprintf "%s => %s" (p.Start.ToString("yyyy-MM-dd")) (p.End.ToString("yyyy-MM-dd")))

// a Temporal<'t> indicates values of type 't on time Periods
// a temporal can contain holes (periods where it is not defined)
// Period in the 
type Temporal<'t> = ('t*Period) list

// this module containing a function to trim a temporal given another
module Temporal =
    // this is a kind of map2.
    // map2 would take a (f: 'a -> 'b -> 'c).. but we cannot pass a value on periods where
    // the temporal is not defined. So the result map2 is defined on the interection of inputs periods.
    // here we pass None as an input when one of the temporal is not define.
    // if the output is None, we don't return a value, if it's some, we return the value on the period.
    let choose2 (f: 'a option -> 'b option -> 'c option) (ta: 'a Temporal) (tb: 'b Temporal) : 'c Temporal =

        // insert value in holes if any, or just leave hole
        let hole =
            match f None None with
            | Some result ->
                // f will always (Some return) result for holes
                // return this value on period if p is not empty
                fun p -> 
                    if Period.isEmpty p then
                        []
                    else
                        [result,p]
            | None ->
                // f will always return None for holes
                fun p -> []

        // call f with x y and return the result as list on period if any
        let choose x y p =
            match f x y with
            | Some result -> [result, p]
            | None -> []

        // d is the current position in time used to fill holes
        // ta is the temporal on the left
        // tb is the temporal on the right
        let rec loop d ta tb = 
            [ match ta, tb with
              | [], [] -> () // we're done
              | [], (vb, pb) :: tailb ->
                // there is just periods on the right
                yield! hole (d => pb.Start) // fill hole if necessary up to start of bb
                yield! choose None (Some vb) pb // output value on period pb if any
                yield! loop pb.End [] tailb // continue to next period on tb
              | (va,pa) :: taila, [] ->
                yield! hole (d => pa.Start) // fill hole if necessary up to start of pa
                yield! choose (Some va) None pa // output value on period pa if any
                yield! loop pa.End taila []  // continue to next period on ta
              | (va,pa) :: taila, (vb, pb) :: tailb ->
                // we have values on ta and tb
                let start = min pa.Start pb.Start
                yield! hole (d => start) // there could be a hole between current d and the start of the first period
                if pa.Start < pb.Start then
                    // pa is starting first.. we have a value on the left and None on the right up to end'
                    let end' = min pa.End pb.Start
                    yield! choose (Some va) None (pa.Start => end') // output value on this start if any
                    if end' < pa.End then
                        // ta head was partially consumed up to end', shorten ta to start at end'
                        yield! loop end' ((va, end' => pa.End) :: taila) tb
                    else
                        // ta head was totally consumed, continue with next period on ta
                        yield! loop end' taila tb
                elif pa.Start > pb.Start then
                    // pb is startting first.. we have None on the left and a value on the right up to end'
                    let end' = min pb.End pa.Start
                    yield! choose None (Some vb) (pb.Start => end') // output value on this start if any
                    if end' < pb.End then
                        // tb head was partially consumed up to end', shorten tb to start at end'
                        yield! loop end' ta ((vb, end' => pb.End) :: tailb)
                    else
                        // tb head was totally consumed, continue with next period on tb
                        yield! loop end' ta tailb
                else 
                    // both head start at same point, we have values on the left and on the right up to end'
                    let end' = min pa.End pb.End
                    yield! choose (Some va) (Some vb) (pa.Start => end') // output value on this period if any
                    if end' = pa.End && end' = pb.End then
                        // both heads are ending together, move to next period on both
                        yield! loop end' taila tailb
                    elif end' = pa.End then
                        // ta ended first, move to next period on ta, and shorten tb
                        yield! loop end' taila ((vb, end' => pb.End) :: tailb)
                    else 
                        // tb ended first, move to next period on tb, and shorten ta
                        yield! loop end' ((va, end' => pa.End) :: taila) tailb
                ]
        loop DateTime.MinValue ta tb
        
    // this function merges consecutives periods with the same value
    let merge (t: 'a Temporal) =
        let rec loop t =
            [
                match t with
                | [] -> ()
                | [ h ] -> yield h
                | (v1,p1) :: ((v2,p2) :: tail2 as tail1) ->
                    if p1.End < p2.Start || v1 <> v2 then
                        // periods are not consecutive..
                        // or values differ, cannot merg
                        yield v1,p1
                        yield! loop tail1
                    else
                        // periods are consecutive with same value, merge
                        // for this, wee rebuild the head with merged period
                        // and loop to try to merge further:
                        yield! loop ((v1, p1.Start => p2.End) :: tail2)
            ]
        loop t



    // this is our trim keep periods where left argument has a value and is different from
    // argument on the right
    let trim t tref =
        choose2 (fun x xref -> if x.IsSome && x <> xref then x else None) t tref 
        |> merge

    // merge consecutive periods with same value

// This is now out profunctor.
// its a function that looks like Temporal.trim, it will take a new value and a 
// reference value, and return a value where only new information is present
// we will mainly use the version with 1 type argument , but we'll not be able
// to implement the applicative without the one with 2 type arguments

// this is the 2 type arguments versions.
// it is contravariant on 'a and covariant on 'b
type Trimer'<'a,'b> = 'a -> 'a -> 'b

// this is the simple version
type Trimer<'t> = Trimer'<'t,'t>

module Trimer =
    // this is a trimer that always returns it's new value input
    // usefull for all 'a that cannot be trimed more than that
    let id : 'a Trimer =
         fun a _ -> a

    // ret or pure
    // lift a value covariantly
    let ret (x: 'b) : Trimer'<'a,'b> =
        fun v rv -> x

    // creates a Temporal<'a> trimer using Temporal.trim 
    let trimTemporal  : 'a Temporal Trimer =
        Temporal.trim 

    // map f covariantly (on the right)
    let rmap (f : 'b -> 'c) (trimer: Trimer'<'a,'b>) : Trimer'<'a,'c> =
        fun x y -> trimer x y |> f

    // map f contravarianly (on the left)
    let lmap (f : 'c -> 'a) (trimer: Trimer'<'a,'b>) : Trimer'<'c, 'b> =
        fun x y -> trimer (f x) (f y)

    // map f covariantly and g contravariantly
    let dimap (f: 's -> 't) (g: 'b -> 'a) (trimer: Trimer'<'a,'s>) : Trimer'<'b,'t> =
        fun (x:'b) (rx: 'b) ->
        
        let xa = g x
        let rxa = g rx
        trimer xa rxa
        |> f

    // dimap2 is not used after...
    // it uses f covariantly with atrimer and btrimer outputs to build a 'u result
    // g and h take a 'c input and contravarianlty extract an 'a and a 'b to pass a atrimer and btrimer inputs
    let dimap2 (f: 's -> 't -> 'u) (g: 'c -> 'a) (h: 'c -> 'b) (atrimer: Trimer'<'a,'s>) (btrimer: Trimer'<'b,'t>) : Trimer'<'c,'u> =
        fun (x: 'c) (rx: 'c) ->
            let xa = g x
            let xb = h x
            let rxa = g rx
            let rxb = h rx
            let va = atrimer xa rxa
            let vb = btrimer xb rxb
            f va vb

    // rmap2 is simpler and is a covariant map2
    // it uses f covariantly with atrimer and btrimer outputs a build a 'u result
    // inputs must all be of the same kind
    let rmap2 (f: 's -> 't -> 'u)  (atrimer: Trimer'<'a,'s>) (btrimer: Trimer'<'a,'t>) : Trimer'<'a,'u> =
        fun (x: 'a) (rx: 'a) ->
            let va = atrimer x rx
            let vb = btrimer x rx
            f va vb

    // rapply is covariant apply
    // it uses map2 to pass the actual value to the actual function
    let rapply (ftrimer: Trimer'<'a, 's -> 't>) (xtrimer: Trimer'<'a, 's>) : Trimer'<'a,'t> =
        rmap2 (fun f x -> f x) ftrimer xtrimer

    // this one is a bidirectional pair using dimap2
    // f pairs values togther, g returns value on the left, h returns value on the right
    let pair atrimer btrimer =
        dimap2 (fun a b -> a,b) fst snd atrimer btrimer

    // this is a dimap3 (not used thereafter)
    let dimap3 (f: 'a -> 'b -> 'c -> 'r) (g: 'r -> 'a) (h: 'r -> 'b) (i: 'r -> 'c) (atrimer: 'a Trimer) (btrimer: 'b Trimer) (ctrimer: 'c Trimer) : 'r Trimer =
        fun (x: 'r) (rx: 'r) ->
            let xa,xb, xc = g x, h x, i x
            let rxa, rxb, rxc = g rx, h rx, i rx
            let va = atrimer xa rxa
            let vb = btrimer xb rxb
            let vc = ctrimer xc rxc
            f va vb vc

    // this takes a trimer of 'a and returns a trimer for 'a list
    // applying ther trimer on elements at the same position in
    // the new value and ther ref value
    let trimList (t: Trimer<'a>) : Trimer<'a list> =
        fun x rx -> List.map2 t x rx

    // this takes a trime of 'a and returns a trimer for maps containing values of type 'a
    // when a key is present in new value but not in the old one, it return the value
    // if the key is present only in oldvalue, it is not returned (it did not change)
    // if the key is present in both, use the trimer to trim the value
    let trimMap (t: Trimer<'a>) : Trimer<Map<'k,'a>> =
        fun x rx ->
            rx
            |> Map.fold (fun m k vr -> // vr is value ref
                match Map.tryFind k m with
                | Some v -> 
                    // the is a corresponding value.. trim it
                    Map.add k (t v vr) m
                | None -> 
                    // there is no corresponding value.. do nothing
                    m
            ) x // result will contain new value even when no ref

// Now lets build a structure that contains data temporal data for our example
// This example is taken from my hotel domain. This sample is simpler than the
// actual one we have. Rooms have more properties, and have rates that have
// several temporal properties themselves..

[<Struct>]
type Avail = Avail of int // Availability wrapper type
[<Struct>]
type Price = Price of decimal // Price wrapper type

// a room has several properties that change in time independently
type Room = { RoomId: int
              Avail: Avail Temporal
              Price: Price Temporal
              Closed: bool Temporal }

// hotel has several rooms
type Hotel = {
        HotelId: int
        Rooms: Map<int,Room>
}

// this module contains functions to build / access properties of Hotel
module Hotel =
    let mk id rooms = { HotelId= id; Rooms = rooms}
    let hotelid h = h.HotelId
    let rooms h = h.Rooms

// this module contains function to build / access properties of Room
module Room = 
    let mk id a p c = { RoomId = id; Avail = a; Price = p; Closed = c }
    let roomid r = r.RoomId
    let avail r= r.Avail
    let price r = r.Price
    let closed r = r.Closed


// We have only the structure, and now we want to create a trimer for an hotel
// it will take an hotel value and reference value, and return a new hotel structure
// containing only what's new

// for this we define operators (for shorter, infix syntax)

let (<!>) f t= Trimer.rmap f t
let (<*>) f t= Trimer.rapply f t
let ( <! ) f t = Trimer.lmap f t

//  the roomid cannot change, so we just return it as is
let roomidTrimer : int Trimer = Trimer.id
// for temporal primitives, we use Trimer.trimTempral
let availTrimer : Avail Temporal Trimer = Trimer.trimTemporal
let priceTrimer : Price Temporal Trimer = Trimer.trimTemporal
let closedTrimer : bool Temporal Trimer = Trimer.trimTemporal

// now we can compose trimers for Room properties 
// into a Room trimer
// we start with the function to build a Room: Room.mk
// we use the applicative on the right (covariantly on the return type)
// So we'll have a Trimer'<_, 'a -> 'b> that we can use with rapply (<*>)
// but on the left, we'll end up with a Trimer'<Room,_> anyway
// the input will be a room.
// but our property trimers take the value of the property as an input : Trimer<'p,_>.
// we can adapt them to take a room with a lmap (<!) and a (Room -> 'p) function, which
// are the function we created to extract the properties from a rooms:
// Room.avail <! availTrimer will be a Trimer'<Room, Avail Temporal> 
// with this, the rapply will recieve Trimer'<Room, _> every time and do the job:
let roomTrimer : Room Trimer =
    Room.mk                             
    <!> (Room.roomid <! roomidTrimer )  
    <*> (Room.avail <! availTrimer)
    <*> (Room.price <! priceTrimer)
    <*> (Room.closed <! closedTrimer)

// for the hotel trimer
// we do the same for the id
let hoteidTrimer : int Trimer = Trimer.id

// the Rooms property of Hotel is a map,
// we use Trimer.trimMap to build a trimer on the map from our Room trimer
let roomsTrimer : Map<int,Room> Trimer =
    Trimer.trimMap roomTrimer

// we use the applicative the same way to build the hotel trimer
let hotelTrimer : Hotel Trimer =
    Hotel.mk
    <!> (Hotel.hotelid <! hoteidTrimer)
    <*> (Hotel.rooms <! roomsTrimer )


// Sample Time, let's test that the hotel trimer is working

// this is a helper function to generate our sample dates in jan 2021
let jan x = DateTime(2021,01,x) 

let hotel = 
    let room1 =
        { RoomId = 1
          Avail = [ Avail 3, jan 3 => jan 5
                    Avail 2, jan 5 => jan 8 ]
          Price = [ Price 100m, jan 2=> jan 5
                    Price 120m, jan 5 => jan 8 ]
          Closed = [ false, jan 2 => jan 7
                     true, jan 7 => jan 8] }
    let room2 =
        { RoomId = 2
          Avail = [ Avail 3, jan 3 => jan 5
                    Avail 2, jan 5 => jan 8 ]
          Price = [ Price 100m, jan 2=> jan 5
                    Price 120m, jan 5 => jan 8 ]
          Closed = [ false, jan 2 => jan 7
                     true, jan 7 => jan 8 ]
                          }
    let room4 =
        { RoomId = 4
          Avail = [ Avail 6, jan 3 => jan 5
                    Avail 3, jan 5 => jan 8 ]
          Price = [ Price 110m, jan 2=> jan 5
                    Price 130m, jan 5 => jan 8 ]
          Closed = [ false, jan 2 => jan 8 ]
                          }
    { HotelId = 1
      Rooms =  [ room1; room2; room4 ]
                |> List.map (fun r -> Room.roomid r, r)
                |> Map.ofList }


let hotelRef = 
    let room1 =
        { RoomId = 1
          Avail = [ Avail 3, jan 3 => jan 6
                    Avail 2, jan 6 => jan 8 ]
          Price = [ Price 100m, jan 3=> jan 5
                    Price 120m, jan 5 => jan 8 ]
          Closed = [ false, jan 2 => jan 6 
                     true, jan 7 => jan 8 ]
                          }

    let room2 =
        { RoomId = 2
          Avail = [ Avail 3, jan 3 => jan 6
                    Avail 2, jan 6 => jan 8 ]
          Price = [ Price 10m, jan 3=> jan 5
                    Price 120m, jan 5 => jan 8 ]
          Closed = [ false, jan 2 => jan 6
                     true, jan 9 => jan 8 ] }

    let room3 =
        { RoomId = 3
          Avail = [ Avail 0, jan 1 => jan 9]
          Price = []
          Closed = [ true, jan 1 => jan 9]}

    { HotelId = 1
      Rooms = [room1; room2; room3]
              |> List.map (fun r -> Room.roomid r, r)
              |> Map.ofList }


let result = hotelTrimer hotel hotelRef

// the result should be the following,
// with room 1 and 2 containing the periods where values have changes
// no room3 since it's not in new input
// and room4 as is since it's only in new input
let expectedResult = 
  { HotelId = 1
    Rooms =
             [{ RoomId = 1
                Avail = [ Avail 2, jan 5 => jan 6 ] // Avail was 3 on 5 => 6
                Price = [ Price 100M, jan 2 => jan 3 ] // Price was not defined on 2 => 3
                Closed = [ false, jan 6 => jan 7 ] } // Closed was not defined on 3 => 7
              { RoomId = 2
                Avail = [ Avail 2, jan 5 => jan 6 ] // avail was 3 on 5 => 6
                Price = [ Price 100M, jan 2 => jan 5 ] // was new on 2 => 3 and different on 3 => 5. Periods got merged
                Closed = [ false, jan 06 => jan 07
                           true, jan 07 => jan 08 ] }
              { RoomId = 4                              // room4 is totally new
                Avail = [ Avail 6, jan 03 => jan 05 
                          Avail 3, jan 05 => jan 08 ]
                Price = [ Price 110M, jan 02 => jan 05 
                          Price 130M, jan 05 => jan 08 ]
                Closed = [ false, jan 02 => jan 08 ] } ]
              |> List.map (fun r -> Room.roomid r, r)
              |> Map.ofList }

// it works !!
expectedResult = result

The level of simplification to this nasty problem is just mind blowing? I feel like my 3rd eye just opened. Thank you

🥰
This has been the work of many years. And now I can even apply it to Deciders (a structure to implement Event Sourcing) to compose them.