REBOL [
    Title: "Prevayler-alike value persistance support functions"
    Purpose: {
        Defines support functions for prevayler-alike persistant values.
    }
    Author: "Gabriele Santilli"
    EMail: giesse@rebol.it
    File: %persist.r
    License: {
Copyright (C) 2003  Gabriele Santilli

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

You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.

http://www.gnu.org/copyleft/gpl.html
    }
    Date: 9-Nov-2004
    Version: 1.15.0 ; majorv.minorv.status
                    ; status: 0: unfinished; 1: testing; 2: stable
    History: [
        18-Oct-2004 1.1.0 "History start"
        18-Oct-2004 1.2.0 "First version"
        18-Oct-2004 1.3.0 "Added PREVALENT?"
        18-Oct-2004 1.4.0 "Added ID?"
        18-Oct-2004 1.5.0 "Added ASSEMBLE/DISASSEMBLE for correct serialization of log operations"
        19-Oct-2004 1.6.0 "Added DISMANTLE-BLOCK and RESTORE-BLOCK"
        19-Oct-2004 1.7.0 "Fixed typo in LOG-OPERATION"
        19-Oct-2004 1.8.0 "Fixed spec for PREVALENT?"
        19-Oct-2004 1.9.0 "Fixed PREVALENT?"
        29-Oct-2004 1.10.0 {
            Removed ASSEMBLE/DISASSEMBLE, now using new DISMANTLE/REBUILD; changed DISMANTLE-BLOCK and REBUILD-BLOCK
            (previously RESTORE-BLOCK); changed the way serialization works. Note: serialization does not work
            yet...
        }
        29-Oct-2004 1.11.0 "Fixed serialization"
        29-Oct-2004 1.12.0 "Little change to DISMANTLE-BLOCK"
        29-Oct-2004 1.13.0 "Fixed SAVE-WORLD"
        29-Oct-2004 1.14.0 "Fixed INIT-WORLD"
         9-Nov-2004 1.15.0 "Added SERIES-REFERENCE! and changed DISMANTLE* for series values"
    ]
]

prevalent?:
    func [
        "Returns true if the value is prevalent (i.e. is of one of the Prevayler-alike persistent types)"
        value [any-type!]
    ] [
        'value
        either all [custom-type? get/any 'value in value/actions 'prevalent?'] [
            value/actions/prevalent?'
        ] [
            false
        ]
    ]

define-action 'id? [
    "Returns the ID of a prevalent value"
    value [object!]
]

define-type 'reference! [ ] [
    rebuild' [ ] [
        pick-value third pieces
    ]
]
define-type 'series-reference! [ ] [
    rebuild' [ ] [
        at* head* pick-value third pieces fourth pieces
    ]
]

dismantle*:
    func [
        "Special version of DISMANTLE for prevalent values"
        value [object!]
    ] [
        if not prevalent? value [invalid-argument value]
        reduce either series?* value [
            ['dismantled 'series-reference! id? value index?* value]
        ] [
            ['dismantled 'reference! id? value]
        ]
    ]

dismantle-block:
    func [block [any-block!] /world] [
        forall block [
            case [
                all [prevalent? pick block 1 not world] [
                    block/1: dismantle* block/1
                ]
                custom-type? pick block 1 [
                    block/1: dismantle block/1
                ]
                all [any-block? pick block 1 'dismantled <> pick block/1 1] [
                    dismantle-block block/1
                ]
            ]
        ]
        head block
    ]
rebuild-block:
    func [block [any-block!]] [
        forall block [
            case [
                all [block? pick block 1 'dismantled = pick block/1 1] [
                    block/1: rebuild block/1
                ]
                any-block? pick block 1 [
                    rebuild-block block/1
                ]
            ]
        ]
        head block
    ]
    
context [
    world: [ ]
    
    recovering: false
    
    log-operation:
        func [op [block!]] [
            if recovering [exit]
            if not exists? %data/ [make-dir %data/]
            write/lines/append %data/log.txt mold/all dismantle-block op
        ]
        
    recover:
        does [
            if not exists? %data/log.txt [exit]
            recovering: yes
            foreach step load/all %data/log.txt [
                do rebuild-block step
            ]
            recovering: no
        ]

    register-value:
        func [value] [
            either id? value [
                poke world id? value value
                id? value
            ] [
                insert tail world :value
                length? world
            ]
        ]
    pick-value:
        func [id /local value] [
            value: pick world id
            if block? value [
                value: rebuild value
            ]
            value
        ]

    save-world:
        has [world2] [
            dismantle-block/world world2: copy world
            if not exists? %data/ [make-dir %data/]
            save/all %data/world2.txt world2
            if exists? %data/world.txt [delete %data/world.txt]
            if exists? %data/log.txt [delete %data/log.txt]
            rename %data/world2.txt %world.txt
        ]

    init-world:
        does [
            if exists? %data/world.txt [
                world: load %data/world.txt
            ]
            recover
        ]

    export [log-operation register-value pick-value save-world init-world]
]