Skip to content

Instantly share code, notes, and snippets.

@praeclarum
Created February 16, 2022 17:11
Show Gist options
  • Save praeclarum/1aa58967451b70f922839701f6c4eb99 to your computer and use it in GitHub Desktop.
Save praeclarum/1aa58967451b70f922839701f6c4eb99 to your computer and use it in GitHub Desktop.
An immutable database with reference entities, cascading deletes, undo buffers, serialization, and reactive variables
namespace Neural
type Id = System.String
type Id<'T> =
| Id of Id
override this.ToString () = match this with Id id -> id
type IEntity =
abstract References : Id seq with get
abstract DeleteReference : Id -> IEntity option
abstract ChangeReferences : Map<Id, Id> -> IEntity
type Database<'T when 'T :> IEntity> =
{
RootId : Id
Entities : Map<Id, IEntity>
}
[<Newtonsoft.Json.JsonIgnoreAttribute>]
member this.Root = this.Entities.[this.RootId] :?> 'T
[<Newtonsoft.Json.JsonIgnoreAttribute>]
member this.HasRoot = this.Entities.ContainsKey this.RootId
static member Empty () =
{
RootId = Id.Empty
Entities = Map.empty
}
module Data =
let private dbError (message : string) (e : exn) = Log.ex message e
let newGenericId () : Id = System.Guid.NewGuid().ToString()
let newId<'T> () : Id<'T> = Id (newGenericId ())
let inline getId<'T> (id : Id<'T>) : Id = match id with Id x -> x
let getIds<'T> (entities : Id<'T> seq) : Id seq = if entities = null then Seq.empty else entities |> Seq.map getId
let allIds db = db.Entities |> Seq.map (fun x -> x.Key) |> Set.ofSeq
let noReferences : Id seq = Seq.empty
let didntChange x : IEntity option = Some x
let deleteReferences<'T when 'T :> IEntity> (r : Id) (a : Id<'T>[]) : Id<'T>[] =
a |> Array.filter(function Id x -> x <> r)
let changeReferences<'T when 'T :> IEntity> (m : Map<Id, Id>) (a : Id<'T>[]) : Id<'T>[] =
a |> Array.map(function Id x -> Id m.[x])
let changeReference<'T when 'T :> IEntity> (m : Map<Id, Id>) (a : Id<'T>) : Id<'T> =
match a with Id x -> Id m.[x]
let changeEntityReference (m : Map<Id, Id>) (a : Id) : Id =
m.[a]
let private reId db =
let newIds =
db.Entities
|> Map.map (fun k v -> newGenericId ())
let newEnts =
db.Entities
|> Seq.map (fun kv -> (newIds.[kv.Key], kv.Value.ChangeReferences newIds))
|> Map.ofSeq
let newRoot =
if newIds.ContainsKey db.RootId then newIds.[db.RootId]
else Id.Empty
{ db with RootId = newRoot; Entities = newEnts }
let rec private gatherReferences (ids : Id seq) db =
let mutable result = ids |> Set.ofSeq
let mutable needsScan = result
let mutable scanned = Set.empty
//printfn "BEGIN SCAN %A" db
while needsScan.Count > 0 do
//printfn "NEED %A" needsScan
let ns = needsScan
needsScan <- Set.empty
for n in ns do
//printfn "SCAN %A" n
scanned <- scanned.Add n
match db.Entities.TryFind n with
| Some e ->
//printfn "SCANE %A" e
try
for r in e.References do
if not (result.Contains r) then
result <- result.Add r
if not (scanned.Contains r) && not (needsScan.Contains r) then
needsScan <- needsScan.Add r
with ex -> dbError "Failed to find references" ex
| _ -> ()
result
and private garbageCollect (db : Database<_>) =
if db.HasRoot then
let reachable = gatherReferences (Seq.singleton db.RootId) db
let toCollect = Set.difference (allIds db) reachable
let newEnts =
db.Entities
|> Map.filter (fun k v -> not (toCollect.Contains k))
if newEnts.Count = db.Entities.Count then db
else { db with Entities = newEnts }
else db
let createDatabase<'T when 'T :> IEntity> (root : 'T) : Database<'T> =
if Seq.isEmpty root.References |> not then
failwith "Root objects must be empty when creating databases"
let id = newId<'T> ()
{
RootId = getId id
Entities = (getId id, root :> IEntity) |> Seq.singleton |> Map.ofSeq
}
/// Creates the entity in the database
let create<'T, 'D when 'T :> IEntity and 'D :> IEntity> (e : 'T) (db : Database<'D>) =
for r in e.References do
if db.Entities.ContainsKey r |> not then
failwithf "Cannot insert %A without first inserting its reference %A" e r
let id = newId<'T> ()
id, { db with Entities = db.Entities.Add (getId id, e) }
/// Creates the entity in the database
let insertAll<'T, 'D when 'T :> IEntity and 'D :> IEntity> (es : 'T[]) (db : Database<'D>) =
let ids = ResizeArray<_>()
let mutable ents = db.Entities
for e in es do
for r in e.References do
if db.Entities.ContainsKey r |> not then
failwithf "Cannot insert %A without first inserting its reference %A" e r
let id = newId<'T> ()
ids.Add id
ents <- ents.Add (getId id, e)
ids.ToArray(), { db with Entities = ents }
/// Determines whether an entity is stored in the database
let exists (id : Id<'T>) db : bool =
match id with Id id -> match db.Entities.TryFind id with
| Some (:? 'T) -> true
| _ -> false
/// Reads a value from the database
let read (id : Id<'T>) db : 'T =
match id with Id id -> match db.Entities.TryFind id with
| Some (:? 'T as e) -> e
| Some x -> failwithf "Expected %A but was %A for id %A" typeof<'T> (x.GetType()) id
| None -> failwithf "No %A with id %A" typeof<'T> id
/// Reads a value from the database
let tryRead (id : Id<'T>) db : 'T option =
match id with Id id -> match db.Entities.TryFind id with
| Some (:? 'T as e) -> Some e
| _ -> None
/// Reads multiple values from the database
let readAll (ids : Id<'T>[]) db : 'T[] =
ids |> Array.map (fun x -> read x db)
/// Reads multiple values from the database with their Id
let readAllWithId (ids : Id<'T>[]) db : (Id<'T> * 'T)[] =
ids |> Array.map (fun x -> (x, read x db))
/// Reads a value from the database
let readEntity (id : Id) db : IEntity = db.Entities.[id]
/// Reads a value from the database
let readAllEntitiesWithId (ids : Id seq) db : (Id * IEntity)[] =
ids |> Seq.map (fun x -> (x, readEntity x db)) |> Array.ofSeq
/// Updates the database to include the entity
let updateRoot<'T when 'T :> IEntity> (e : 'T) (db : Database<'T>) =
for r in e.References do
if db.Entities.ContainsKey r |> not then
failwithf "Cannot update %A without first inserting its reference %A" e r
{ db with Entities = db.Entities.Add (db.RootId, e) }
/// Updates the database to include the entity
let update<'T, 'D when 'T :> IEntity and 'D :> IEntity> (id : Id<'T>) (e : 'T) (db : Database<'D>) =
for r in e.References do
if db.Entities.ContainsKey r |> not then
failwithf "Cannot update %A without first inserting its reference %A" e r
{ db with Entities = db.Entities.Add (getId id, e) }
let updateEntity<'T, 'D when 'T :> IEntity and 'D :> IEntity> (id : Id<'T>) (f : 'T -> 'T) (db : Database<'D>) =
let oe = read id db
let e = f oe
for r in e.References do
if db.Entities.ContainsKey r |> not then
failwithf "Cannot update %A without first inserting its reference %A" e r
{ db with Entities = db.Entities.Add (getId id, e) }
let updateEntities<'T, 'D when 'T :> IEntity and 'D :> IEntity> (update : 'T -> 'T) (db : Database<'D>) : Database<'D> =
let newEnts =
db.Entities
|> Map.map (fun k v ->
match v with
| :? 'T as l -> update l :> IEntity
| _ -> v)
{ db with Entities = newEnts }
let updateEntitiesWithIds<'T, 'D when 'T :> IEntity and 'D :> IEntity> (update : Id<'T> -> 'T -> 'T) (db : Database<'D>) : Database<'D> =
let newEnts =
db.Entities
|> Map.map (fun k v ->
match v with
| :? 'T as l -> update (Id k) l :> IEntity
| _ -> v)
{ db with Entities = newEnts }
/// Cascade delete an entity from the database
let rec delete (ids : Id seq) db =
let mutable todel = List.ofSeq ids
let mutable deleted = Set.empty
let mutable r = db
while todel.Length > 0 do
let did = todel.Head
if did = r.RootId then
r <- { r with RootId = Id.Empty }
deleted <- deleted.Add did
todel <- todel.Tail
let newEnts =
r.Entities.Remove did
|> Map.map (fun i x ->
try
if Seq.contains did x.References then
x.DeleteReference did
else Some x
with ex -> dbError "Failed to delete references" ex; Some x)
let delEnts =
newEnts
|> Map.filter (fun id e -> Option.isNone e)
let goodEnts =
newEnts
|> Map.filter (fun id e -> Option.isSome e)
let newToDel =
delEnts
|> Seq.filter (fun x -> not (deleted.Contains x.Key))
|> Seq.map (fun x -> x.Key)
|> List.ofSeq
todel <- List.append todel newToDel
r <- { r with Entities = goodEnts |> Map.map (fun i x -> x.Value) }
r
|> garbageCollect
let deleteAll<'T, 'D when 'T :> IEntity and 'D :> IEntity> (ids : Id<'T> seq) (db : Database<'D>) =
db |> delete (ids |> getIds)
let copy (ids : Id seq) db =
let implicitReferences = gatherReferences ids db
let toDelete = Set.difference (allIds db) implicitReferences
let trimmedDb = delete toDelete db
let copyDb = reId trimmedDb
copyDb
let cut (ids : Id seq) db =
let implicitReferences = gatherReferences ids db
let toDelete = Set.difference (allIds db) implicitReferences
let trimmedDb = delete toDelete db
let copyDb = reId trimmedDb
let newDb = delete ids db
(newDb, copyDb)
open Newtonsoft.Json
module private Json =
type IdConverter () =
inherit JsonConverter ()
let mutable readers = Map.empty
let mutable writers = Map.empty
override this.CanConvert typ =
typ.Name = "Id`1"
override this.ReadJson (reader, objectType, existing, serializer) =
let s = reader.Value :?> string
let id = s
let key = objectType.FullName
match readers.TryGetValue key with
| true, rd -> rd(id)
| false, _ ->
let meth = objectType.GetMethod ("NewId")
let rd(id : Id) = meth.Invoke (null, [| id :> obj |])
readers <- readers.Add (key, rd)
rd(id)
override this.WriteJson (writer, value, serializer) =
let objectType = value.GetType()
let key = objectType.FullName
match writers.TryGetValue key with
| true, wr -> wr(writer, value)
| false, _ ->
let prop = objectType.GetProperties() |> Seq.find (fun x -> x.Name = "Item")
let wr(w : JsonWriter, o : obj) =
let s = prop.GetValue (o, null)
w.WriteValue s
writers <- writers.Add (key, wr)
wr(writer, value)
let settings = new JsonSerializerSettings (TypeNameHandling = Newtonsoft.Json.TypeNameHandling.Auto,
Formatting = Newtonsoft.Json.Formatting.Indented)
do settings.Converters.Add (IdConverter ())
type Database<'T when 'T :> IEntity> with
static member FromJson (json : string) =
Newtonsoft.Json.JsonConvert.DeserializeObject<Database<'T>> (json, Json.settings)
member this.ToJson () =
Newtonsoft.Json.JsonConvert.SerializeObject (this, Json.settings)
type State<'T> (initialState : 'T) =
let ev = new Event<_,_> ()
let ev2 = new Event<_,_> ()
let mutable value = initialState
member this.Value
with get () = value
and set value' =
ev2.Trigger (this, System.ComponentModel.PropertyChangingEventArgs ("Value"))
value <- value'
ev.Trigger (this, System.ComponentModel.PropertyChangedEventArgs ("Value"))
[<CLIEvent>]
member this.PropertyChanged = ev.Publish
[<CLIEvent>]
member this.PropertyChanging = ev2.Publish
interface System.ComponentModel.INotifyPropertyChanging with
member this.add_PropertyChanging(handler) = ev2.Publish.AddHandler(handler)
member this.remove_PropertyChanging(handler) = ev2.Publish.RemoveHandler(handler)
interface System.ComponentModel.INotifyPropertyChanged with
member this.add_PropertyChanged(handler) = ev.Publish.AddHandler(handler)
member this.remove_PropertyChanged(handler) = ev.Publish.RemoveHandler(handler)
type Undo<'T> =
{
Revisions : Revision<'T>[]
Index : int
}
member this.Value = this.Revisions.[this.Index].Value
and Revision<'T> =
{
Value : 'T
Title : string
}
module Undo =
let newUndo<'T> (initialValue : 'T) =
{
Revisions = [| { Value = initialValue; Title = "Initial" } |]
Index = 0
}
let registerUndo undo title newValue =
let r = { Value = newValue; Title = title }
{
Revisions = Array.append (Array.take (undo.Index + 1) undo.Revisions) [| r |]
Index = undo.Index + 1
}
let doUndo undo =
if undo.Index > 0 then
{ undo with Index = undo.Index - 1 }
else
undo
let doRedo undo =
if undo.Index + 1 < undo.Revisions.Length then
{ undo with Index = undo.Index + 1 }
else
undo
type Var<'T> (getter : unit -> 'T, setter : 'T -> unit) =
let propertyChanged = Event<_, _> ()
member this.Value
with get () = getter ()
and set x =
try
setter x
this.OnValueChanged ()
with ex ->
Log.ex "Set Value" ex
member this.OnValueChanged () =
propertyChanged.Trigger (this, System.ComponentModel.PropertyChangedEventArgs ("Value"))
[<CLIEvent>]
member this.PropertyChanged = propertyChanged.Publish
interface System.ComponentModel.INotifyPropertyChanged with
member this.add_PropertyChanged(handler) = propertyChanged.Publish.AddHandler(handler)
member this.remove_PropertyChanged(handler) = propertyChanged.Publish.RemoveHandler(handler)
type MappedVar<'T, 'U> (project : 'T -> 'U, unproject : 'T -> 'U -> 'T, variable : Var<'T>) as this =
inherit Var<'U> ((fun () -> project variable.Value), (fun x -> variable.Value <- unproject variable.Value x))
let sub = variable.PropertyChanged.Subscribe (fun e ->
this.OnValueChanged ())
type OptionallyMappedVar<'T, 'U> (project : 'T -> 'U option, unproject : 'T -> 'U -> 'T, variable : Var<'T>) as this =
inherit Var<'U option> ((fun () -> project variable.Value), (function Some x -> variable.Value <- unproject variable.Value x | _ -> ()))
let sub = variable.PropertyChanged.Subscribe (fun e ->
this.OnValueChanged ())
module Var =
let map<'T, 'U> (project : 'T -> 'U) (unproject : 'T -> 'U -> 'T) (variable : Var<'T>) : Var<'U> =
upcast MappedVar<'T, 'U> (project, unproject, variable)
let omap<'T, 'U> (project : 'T -> 'U option) (unproject : 'T -> 'U -> 'T) (variable : Var<'T>) : Var<'U option> =
upcast OptionallyMappedVar<'T, 'U> (project, unproject, variable)
@praeclarum
Copy link
Author

praeclarum commented Feb 16, 2022

Here's an example entity that has two lists of references to two other entity types.

type Thing =
    {
        OtherThings : Id<OtherThing>[]
        MoreThings : Id<AnotherThing>[]
        SomeValue : int
    }
    interface IEntity with
        override this.References = 
            [
                this.OtherThings |> getIds
                this.MoreThings |> getIds
            ]
            |> Seq.concat
        override this.DeleteReference r =
            { this with
                OtherThings = this.OtherThings |> deleteReferences r
                MoreThings = this.MoreThings |> deleteReferences r
            }
            :> IEntity
            |> Some
        override this.ChangeReferences r =
            { this with
                OtherThings = this.OtherThings |> changeReferences r
                MoreThings = this.MoreThings |> changeReferences r
            }
            :> IEntity

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment