Wednesday 21 August 2013

Primitive rebol object browser

The system object is difficult to analyze and study, so there is this simple script to read system:


Here is the source:

REBOL [
    Title: "Primitive Rebol Object Browser"
    Date: 01-nov-2001
    File: %prob.r
    Author: "HY"
    Purpose: "Make a graphical view of the probe function so that users may probe the system object without having to look it all up in the console."
]
path-words: copy []
list-index: 4 ; this should have been 1, but we add 3 for the lay-out components...
main-styles: stylize [
  list: text-list 180x200 feel [
    detect: func [face event] [
      if event/1 = 'up [
        if not equal? "" to-string face/picked [
          ; make sure clicks on the slider are ignored:
          event-offset: event/offset - face/offset
          if event-offset/x >= face/sld/offset/x [ return event ]
          ; if we get here, everything is ok.
          ; Now make sure only one item is selected:
          if (length? face/picked) > 1 [
            ;print "Faen steike! Mer enn én dings er valgt!"
            ; hvorfor funker ikke dette:
            ;face/picked: face/picked/1
            ;print "Det får holde med den første."
            show face
          ]
          list-clicked: index? find face/parent-face/pane face ;list1 = 4
                                                              ;list2 = 5
                                                              ;list3 = 6
                                                              ;list4 = 7
          ;print ""
          ;print ["list-index er" list-index "og list-clicked er" list-clicked]
          while [list-index > list-clicked] [
            remove back tail path-words
            ;if list-index < 8 [
              clear face/parent-face/pane/:list-index/lines
              clear face/parent-face/pane/:list-index/picked
              show face/parent-face/pane/:list-index ; immediately update
            ;]
            list-index: list-index - 1
          ]
          ;print ["list-index er" list-index "og list-clicked er" list-clicked]
          to-append: to-word to-string face/picked/1
          while [all [((length? path-words) > (list-clicked - 3)) list-clicked < 7]] [
            ;print ["(length? path-words) > (list-clicked - 3) er"
            ;         (length? path-words) > (list-clicked - 3)]
            ;print ["length? path-words er" (length? path-words)]
            ;print ["list-clicked er" list-clicked]
            move-lists-right
            list-clicked: min 7 list-clicked + 1
          ]
          append path-words to-append
          path-text/text: to-path path-words
          show path-text
          ; set up right highlight colour:
          for x 4 7 1 [
            face/parent-face/pane/:x/iter/feel/set-high-col either (x = list-clicked) [240.240.50] [130.130.130]
            show face/parent-face/pane/:x
          ]
          ;print ["list-index er" list-index "og list-clicked er" list-clicked]
          list-index: list-clicked + 1 ; list-index is the one we're manipulating,
                                      ; i.e. the one to the right of list-clicked
          ;print "^(1B)[J" ; clear screen ; ] (added end bracket so that textpad may find the right brackets)
          to-display: do compose [(to-path path-words)] ;to-path path-words
          c: do compose [(to-path copy/part path-words (length? path-words) - 1)]
          if unset? get/any in c last path-words [
            pop-up join form to-path path-words ": undefined"
            if list-index = 8 [ list-index: 7 ]
            return
          ]
          if any-function? get in c last path-words [
            cc: get in c last path-words
            pop-up source-string cc
            if list-index = 8 [ list-index: 7 ]
            return
          ]
          if object? get in c last path-words [
            if list-index = 8 [ ; 8 would be the slider bar
              ;print ""
              ;print reduce ["list4/lines er" mold list4/lines]
              move-lists-left
              list4/iter/feel/set-high-col 240.240.50
              list-index: 7
            ]
            ;face/parent-face/pane/:list-index/lines: sort first to-display
            face/parent-face/pane/:list-index/lines: sort first get in c last path-words
            face/parent-face/pane/:list-index/data: sort first get in c last path-words
            clear face/parent-face/pane/:list-index/picked
            update-slider face/parent-face/pane/:list-index
            show face/parent-face/pane/:list-index ; update this view again
            return
          ]
          if port? get in c last path-words [
            pop-up mold get in c last path-words
            if list-index = 8 [ list-index: 7 ]
            return
          ]
          if block? get in c last path-words [
            pop-up mold get in c last path-words
            if list-index = 8 [ list-index: 7 ]
            return
          ]
          pop-up to-string to-display
          if list-index = 8 [list-index: 7 remove back tail path-words ]
        ] ; end face/picked not ""
      ] ; end event/1 = 'up
      return event
    ] ; end detect
  ] ; end list
] ; end main-styles
move-lists-left: func [] [
  ;print "Flytter listene ett hakk til venstre"
  list1/lines: head copy list2/lines
  list1/picked: copy list2/picked
  list1/iter/feel/set-high-col list2/iter/feel/high-col
  show list1
  update-slider list1
  list2/lines: head copy list3/lines
  list2/picked: copy list3/picked
  list2/iter/feel/set-high-col list3/iter/feel/high-col
  show list2
  update-slider list2
  list3/lines: head copy list4/lines
  list3/picked: copy list4/picked
  list3/iter/feel/set-high-col list4/iter/feel/high-col
  show list3
  update-slider list3
  ; don't need to mess with list4, as we do so in feel code itself
]
move-lists-right: func [/local to-remove list1-path] [
  list4/lines: head copy list3/lines
  list4/picked: copy list3/picked
  show list4
  update-slider list4
  list3/lines: head copy list2/lines
  list3/picked: copy list2/picked
  show list3
  update-slider list3
  list2/lines: head copy list1/lines
  list2/picked: copy list1/picked
  show list2
  update-slider list2
  to-remove: (length? path-words) - (list-clicked - 3)
  list1-path: to-path head remove/part at copy path-words ((length? path-words) - (to-remove - 1)) to-remove
  list1/lines: sort first list1-path
  list1/picked: to-block first find head list1/lines first at path-words ((length? path-words) - (to-remove - 1))
  show list1
  update-slider list1
]
update-slider: func [faces [object! block!]] [
  foreach lv-list to-block faces [
    lv-list/sn: 0
    lv-list/sld/data: 0
    lv-list/sld/redrag lv-list/lc / max 1 length? head lv-list/lines
    show lv-list
  ]
]
pop-up: func [to-show /name 'word] [
  l: layout [
    info 300x300 to-show
    button "Close" [hide-popup]
  ]
  inform l
]
source-string: func [
    "Returns the source code for a word, as a string."
    'word [word!]
    /local return-value
][
    ;return-value: join "system/words/" [word ": "]
    return-value: to-string reduce [word ": "]
    if not value? word [append return-value "undefined" return return-value]
    if native? get word [
        append return-value "native"
        append return-value mold third get word
        return return-value
    ]
    if op? get word [
        append return-value "op"
        append return-value mold third get word
        return return-value
    ]
    if action? get word [
        append return-value "action"
        append return-value mold third get word
        return return-value
    ]
    append return-value mold get word
    return return-value
]
PROB: func ['to-be-probed] [
  if not value? 'to-be-probed [to-be-probed: 'system]
  if any [any-function? get to-be-probed port? get to-be-probed] [
    pop-up source-string :to-be-probed
    exit
  ]
  clear path-words
  append path-words to-be-probed
  to-display: do compose [(to-path path-words)] ;to-path path-words
  dom?: attempt [do-browser "true;"]
  link: either dom? ["Try Romano Paolo Tenca's AnaMonitor!"] [""]
  main: layout [
    styles main-styles
    title "Primitive Rebol Object Browser"
    text "Current path: "
    path-text: text form to-path path-words 745x16
    across
    list1: list data sort first to-display
    list2: list
    list3: list
    list4: list
    below
    ;slider1: slider 745x16 [
    ;]
    across
    button "Quit" [quit]
    box 400x1
    text 200 underline blue center link feel [
      over: func [face act pos] [
        face/font/style: either act [[bold]][[underline]]
        show face
      ]
      engage: func [face action event] [
        if action = 'down [ if dom? [ do-browser {top.location.href="http://www.rebol.net/plugin/demos/anamonitor.html";} ] ]
      ]
    ]
  ]
  list1/iter/feel: make list1/iter/feel [
    high-col: 240.240.50 ; actually rebol default colour.
    set-high-col: func [colour] [high-col: colour ]
    redraw: func[f a i] bind [
      f/color: either find picked f/text [high-col] [slf/color]
    ] in list1 'self
  ]
  list2/iter/feel: make list2/iter/feel [
    high-col: 240.240.50
    set-high-col: func [colour] [high-col: colour ]
    redraw: func[f a i] bind [
      f/color: either find picked f/text [high-col] [slf/color]
    ] in list2 'self
  ]
  list3/iter/feel: make list3/iter/feel [
    high-col: 240.240.50
    set-high-col: func [colour] [high-col: colour ]
    redraw: func[f a i] bind [
      f/color: either find picked f/text [high-col] [slf/color]
    ] in list3 'self
  ]
  list4/iter/feel: make list4/iter/feel [
    high-col: 240.240.50
    set-high-col: func [colour] [high-col: colour ]
    redraw: func[f a i] bind [
      f/color: either find picked f/text [high-col] [slf/color]
    ] in list4 'self
  ]
  view main
]
prob system

No comments:

Post a Comment