REBOL [
  Title: "Image panning face"
  Author: ["Henrik Mikael Kristensen"]
  Copyright: "2006 - HMK Design"
  Filename: %pan-image.r
  Version: 0.0.2
  Created: 21-aug-2006
  Date: 21-aug-2006
  License: {
    BSD (www.opensource.org/licenses/bsd-license.php)
    Use at your own risk.
  }
  Purpose: {
    Image face that allows panning of larger images and scrolling of small images.
  }
  History: []
]

stylize/master [
  PAN-IMAGE: FACE with [
    image: none
    pane: none
    color: 100.100.100
    edge: none
    font: none
    size: 100x100
    clamp: func [face /local left-corner right-corner] [
      left-corner: 0x0
      right-corner: face/parent-face/size - face/size
      face/offset/x:
        either face/parent-face/size/x > face/size/x [
          max min face/offset/x right-corner/x left-corner/x
        ][
          max min face/offset/x left-corner/x right-corner/x
        ]
      face/offset/y:
        either face/parent-face/size/y > face/size/y [
          max min face/offset/y right-corner/y left-corner/y
        ][
          max min face/offset/y left-corner/y right-corner/y
        ]
      face
    ]
    access: make object! [
      set-face*: func [face value][
        if any [image? value none? value] [
          face/pane/1/image: value
          face/pane/1/offset: 0x0
          if image? value [
            face/pane/1/size: value/size
          ]
        ]
      ]
      get-face*: func [face][face/pane/1/image]
      clear-face*: func [face][face/pane/1/image: none]
    ]
    feel: make feel [
      engage: func [face act evt /local f] [
        f: face/pane/1
        if find [down alt-down] act [focus/no-show face]
        if 'key = act [
          f/offset: add f/offset multiply switch/default evt/key [
            up [0x-1]
            down [0x1]
            left [-1x0]
            right [1x0]
            page-up [0x-1]
            page-down [0x1]
            home [0x-1]
            end [0x1]
          ][0x0] any [
            case [
              evt/shift [
                either find [up down] evt/key [f/size/y][f/size/x]
              ]
              evt/control [
                either find [up down] evt/key [face/size/y][face/size/x]
              ]
              find [page-up page-down] evt/key [f/size/y]
              find [home end] evt/key [face/size/y]
            ]
            20
          ]
          clamp f
        ]
        if find [scroll-line scroll-page] act [
          f/offset: add f/offset multiply
            either negative? second evt/offset [
              either evt/shift [-1x0][0x-1]
            ][
              either evt/shift [1x0][0x1]
            ] either 'scroll-page = act [f/size/y][40]
          clamp f
        ]
        show face
      ]
    ]
    pane: reduce [
      make face [
        offset: 0x0
        start: 0x0
        color: none
        feel: make feel [
          engage: func [face act evt][
            if find [down alt-down] act [
              focus/no-show face/parent-face
              face/start: evt/offset
            ]
            if find [over away] act [
              face/offset: face/offset + evt/offset - face/start
              clamp face
              show face
            ]
          ]
        ]
        edge: none
      ]
    ]
    init: [
      if image [
        pane/1/size: image/size
        pane/1/image: image
        image: none
      ]
    ]
  ]
]