Rebol [
    Title: Name: "Memory Watcher"
    Author: "Nenad Rakocevic"
    Email: dockimbel@free.fr
    Date: 12/02/2001
    File: %mem-watch.r
    Version: 1.0.0
    Purpose: "Watch memory evolve during a console session"
    Needs: [view]
    Usage: {
        Just do :
            >> do %mem-watch.r
        
        then at any time :
            >> mem-watch
        
        Now you're in the mem-watch console (rebol-like). Type anything
        on the command-line and watch memory change !
        
        The red background shows last modified values.
        
        Type 'quit to exit from mem-watcher.
        
        You can even run complete scripts, but you'll see memory
        changes only after the end of your script.
        If you want to see changes during your script evaluation,
        just place in your script calls to the 'refresh-watcher
        function.
        
        refresh-watcher         ; update the memory window.
        refresh-watcher/wait    ; update the memory window and wait until
                                ; you press a key.
                                
        Note: a 'recycle is done each time the prompt is printed.
    }
    Comment: {
        - All the infos are taken for Carl's mem-stats.r script.
        - If you're always worrying about memory, mem-watch will show you
          where it's gone !
        - Won't work with /View apps (for now)
        - This script could much more handier if it could show also 
          the difference between two updates for each values.
        - 'Throws are not catched in the mem-watch console.
        - I'm not sure that my approach is really accurate. 8/
    }
]

watcher-object: context [
    norm-color: 255.255.255
    high-color: 250.160.160

    watcher: total: plane: none
    
    set 'refresh-watcher func [/wait /local blk val row item p-face][
        ;--- Updating total mem ---
        either total/text = val: mold system/stats [
            total/color: norm-color
        ][
            total/text: :val 
            total/color: high-color
        ]   
        ;--- Updating general infos ---
        blk: join join system/stats/recycle system/stats/series system/stats/frames
        p-face: plane/pane
        foreach item blk [
            either p-face/1/text = val: mold item [
                p-face/1/color: norm-color
            ][
                p-face/1/text: :val
                p-face/1/color: high-color
            ]
            p-face: next p-face
        ]
        ;--- Updating pools ---
        blk: system/stats/pools
        p-face: at plane/pane 19
        foreach row blk [
            foreach item row [
                either p-face/1/text = val: mold item [
                    p-face/1/color: norm-color
                ][
                    p-face/1/text: :val
                    p-face/1/color: high-color
                ]
                p-face: next p-face
            ]
        ]
        show watcher
        if wait [ask "Press Enter key to continue..."]
    ]

    ss: stylize [
        lab: tt 60 right black font [] 
            edge [size: 1x1 color: 144.144.144 effect: 'ibevel] 
            with [color: norm-color]
        txt: txt no-wrap 0.0.80
            edge [size: 1x1 color: 144.144.144 effect: 'ibevel] 
            with [color: 188.188.188]
        txt60: txt 60 center
        txt-large: txt 175x18
        pool-face: face 60x18 
            edge [size: 1x1 color: 144.144.144 effect: 'ibevel] 
            font [color: 0.0.0 shadow: none align: 'center]
            with [color: norm-color init: []]
    ]

    set 'mem-watch func [/local watch-win pos cmd err][
        unview/all
        watcher: layout [
            styles ss
            size 605x440
            plane: backdrop 188.188.188
            space 0
            at 0x0 h5 "Total memory allocated" 0.0.80
            at 175x0 total: pool-face right "0"
            origin 60x38
            txt-large "recycles since boot"
            txt-large "series recycled since boot"
            txt-large "series last recycled"
            txt-large "frames recycled since boot"
            txt-large "frames last recycled"
            txt-large "ballast remaining"

            txt-large "total series"
            txt-large "block series"
            txt-large "string series"
            txt-large "other series"
            txt-large "unused series"
            txt-large "free series (= unused)"
            txt-large "expansions performed"

            txt-large "frames"
            txt-large "frames in use"
            txt-large "frames not in use"
            txt-large "free frames (= unused)"
            txt-large "values held in frames"

            across at 240x0
            txt60 "Width" txt60 "Units" txt60 "Free" txt60 "Segment" txt60 "Units/Alloc"
            txt60 "Bytes"
            do [
                plane/pane: make block! (23 * 6) + 18
                pos: 0x0
                loop 18 [
                    append plane/pane make ss/pool-face [
                        offset: pos + 0x38
                        font: make font [align: 'right]
                    ]
                    pos/y: pos/y + 18
                ]   
                pos: 0x0
                loop 23 [
                    loop 6 [
                        append plane/pane make ss/pool-face [offset: pos + 240x20]
                        pos/x: pos/x + 60
                    ]
                    pos/x: 0
                    pos/y: pos/y + 18
                ]
                recycle
            ]
        ]
        watcher/offset: to-pair reduce [system/view/screen-face/size/x - watcher/size/x 0]
        watch-win: view/new watcher

        ;--- Rebol console emulator ---
        print "^/Entering Memory Watcher...(type 'quit to exit)"
        forever [
            refresh-watcher
            recycle
            cmd: ask "[mem-watcher]>> "
            either "quit" = trim cmd [
                unview/only watch-win halt
            ][
                either error? set/any 'err try [do cmd][
                    err: disarm err
                    print ["**" err/type "error:" err/id "on" remold [err/arg1]]
                    print ["** Where:" mold err/near]
                ][
                    if all [
                        not unset? 'err
                        value? 'err
                        not object? err
                        not port? err
                    ][
                        if all [series? :err 80 < length? :err][
                            err: join mold copy/part err 80 "..."
                        ]   
                        print rejoin [system/console/result :err]
                    ]
                ]
                unset 'err
            ]
        ]
    ]
]

;You should comment this line (this is only usefull when running from TestPanel)
mem-watch