Garbo/Garbo.cdr/mac/hypercrd/xcmd/prctclxf.sit/DemoStack/stack.txt

Text File | 1990-08-28 | 14KB | 486 lines

-- stack: in
-- format: 8 (HyperCard 1)
-- flags: 0x1000 (none)
-- protect password hash: 0
-- maximum user level: 5 (scripting)
-- window: Rect(x1=0, y1=0, x2=0, y2=0)
-- screen: Rect(x1=0, y1=0, x2=0, y2=0)
-- card dimensions: w=0 h=0
-- scroll: x=0 y=0
-- background count: 2
-- first background id: 2685
-- card count: 14
-- first card id: 3017
-- list block id: 8397
-- print block id: 8547
-- font table block id: 0
-- style table block id: 0
-- free block count: 0
-- free size: 0 bytes
-- total size: 99904 bytes
-- stack block size: 14336 bytes
-- created by hypercard version: 0x01208000
-- compacted by hypercard version: 0x01208000
-- modified by hypercard version: 0x01208000
-- opened by hypercard version: 0x01208000
-- patterns[0]: 0x0000000000000000
-- patterns[1]: 0x8000000008000000
-- patterns[2]: 0x8800220088002200
-- patterns[3]: 0x8888222288882222
-- patterns[4]: 0x88AA22AA88AA22AA
-- patterns[5]: 0xCCAA33AACCAA33AA
-- patterns[6]: 0xEEAABBAAEEAABBAA
-- patterns[7]: 0xEEBBBBEEEEBBBBEE
-- patterns[8]: 0xFFBBFFEEFFBBFFEE
-- patterns[9]: 0xFFBBFFFFFFBBFFFF
-- patterns[10]: 0x8010022001084004
-- patterns[11]: 0xFFFFFFFFFFFFFFFF
-- patterns[12]: 0x8822882288228822
-- patterns[13]: 0x1122448811224488
-- patterns[14]: 0xC4800C6843023026
-- patterns[15]: 0xB130031BD8C00C8D
-- patterns[16]: 0xAA00AA00AA00AA00
-- patterns[17]: 0x8822552288225522
-- patterns[18]: 0x8855225588552255
-- patterns[19]: 0x77DD77DD77DD77DD
-- patterns[20]: 0x8000000000000000
-- patterns[21]: 0xAA55AA55AA55AA55
-- patterns[22]: 0x038448300C020101
-- patterns[23]: 0x8244394482010101
-- patterns[24]: 0x8814224188412214
-- patterns[25]: 0x8080413E080814E3
-- patterns[26]: 0x22048C7422179810
-- patterns[27]: 0xBE808808EB088880
-- patterns[28]: 0x25C8328964244C92
-- patterns[29]: 0xA29C41BE2AC914EB
-- patterns[30]: 0x40A00000040A0000
-- patterns[31]: 0x8040200002040800
-- patterns[32]: 0xAA00800088008000
-- patterns[33]: 0xFF80808080808080
-- patterns[34]: 0x081C22C180010204
-- patterns[35]: 0xFF808080FF080808
-- patterns[36]: 0xF87422478F172271
-- patterns[37]: 0xBF00BFBFB0B0B0B0
-- patterns[38]: 0xFF7FBE5DA2418000
-- patterns[39]: 0xFAF5FAF5A050A050
-- checksum: 0x0
----- HyperTalk script -----
on openStack
  global userName
  if (not validVersion()) then go stack "Home"
  set userlevel to 5
  put (userName contains "Ari Halberstadt") into me
  set visible of bkgnd btn "Debugging" to me
  get debugging((me) and (hilite of bkgnd btn "Debugging"))
  set textArrows to true
  get initRadio()
  hide menubar
  get lockMenuBar(false)
  pass openStack
end openStack

-- check version of HyperCard
function validVersion
if (the version < 1.2) then
  answer "This stack requires HyperCard version 1.2." with "Go Home"
  return false
end if
return true
end validVersion

on closeStack
  if (the version < 1.2) then pass closeStack
  if (debugging() = true) then pass closeStack
  get endRadio()
  pass closeStack
end closeStack

on openCard
  if (debugging() = true) then
    set the lockText of field "Description" to false
    pass openCard
  end if

  set the lockText of field "Description" to true
  set the scroll of field "Description" to 0

  -- display the card's header
  updateHeader

  pass openCard
end openCard

-- Update the header displayed on most (or all) cards
on updateHeader
  put "DemoStack 0.9" into field "HeaderLeft"
  put the short name of this card into field "HeaderRight"
  put "Card #" & the number of this card into field "HeaderNumber"
end updateHeader

----------------------------------------------------------------------
-- menu handlers
----------------------------------------------------------------------

on doMenu menuItem
  if (menuItem = "Help") then GoHelp
  else pass doMenu
end doMenu

----------------------------------------------------------------------
-- misc. stuff
----------------------------------------------------------------------

-- return true if debugging, else false
function debugging value
global _gDebugging
if (value Γëá empty) then put value into _gDebugging
return _gDebugging
end debugging

-- lock state of menu bar
function lockMenuBar value
global _gLockMenuBar
if (value Γëá empty) then put value into _gLockMenuBar
return _gLockMenuBar
end lockMenuBar

----------------------------------------------------------------------
-- Handlers for moving around in the stack
----------------------------------------------------------------------

on GoPrevious
  visual wipe right fast
  go previous
end GoPrevious

on GoNext
  visual wipe left fast
  go next
end GoNext

on GoFirst
  visual scroll right fast
  go card 1
end GoFirst

on GoLast
  visual scroll left fast
  go card the number of cards in this stack
end GoLast

on GoBack
  visual iris close
  go back
end GoBack

on GoHelp
  visual zoom open
  answer "Sorry, no help yet."
  exit GoHelp
  go card "Help"
end GoHelp

on GoIndex
  visual zoom open
  go card "Index"
end GoIndex

on GoHome
  visual zoom close
  go to this card
  go home
end GoHome

on GoThinkC
  answer "Really launch THINK C?" with "No" or "Yes"
  if (it = "Yes") then
    visual zoom open
    go to this card
    open "THINK C 1:THINK C"
  end if
end GoThinkC

-------------------------------------------------------------------
-- Return the line number of the field "What" based on the point
-- "Where". A typical way to call this function from a field is:
--     get clickLine(the target, the clickLoc)
-- This function will work both for scrolling and non-scrolling
-- fields.
-------------------------------------------------------------------
function clickLine what, where
-- get the line number user clicked on
put the textHeight of what into txtHt
put item 2 of where into loc
put item 2 of the rect of what into top
put loc-top into offset
if (the style of what = "scrolling") then
  return( trunc( (offset + scroll of what) / txtHt ) + 1 )
else
  return( trunc( offset / txtHt ) + 1 )
end if
end clickLine

-------------------------------------------------------------------
-- Put the named file into the named background field
-------------------------------------------------------------------
on putFileIntoField fileName, fieldName
  open file fileName
  if (the result <> empty) then
    answer "Can't open file '" & fileName "'." with "OK"
    exit putFileIntoField
  end if
  read from file fileName for 16384
  put it into field fieldName
  close file fileName
end putFileIntoField

-------------------------------------------------------------------
-- Put the named background field into the named file
-------------------------------------------------------------------
on putFieldIntoFile fieldName, fileName
  open file fileName
  if (the result <> empty) then
    answer "Can't open file '" & fileName "'." with "OK"
    exit putFieldIntoFile
  end if
  write field fieldName to file fileName
  close file fileName
end putFieldIntoFile

-----------------------------------------------------------------------
-- Sort data using an array list. Returns the sorted data, or
-- empty if error.
-- Parameters:
--   data      The data to sort
--   compare   Rules for comparing items
--   separator Character separating data items
--   presorted If true, advises sort function that data are already
--             nearly sorted.
--   method    Either empty, "Sort", "QuickSort", or "ShellSort"
-----------------------------------------------------------------------
function listSort data, compare, separator, presorted, method
set cursor to watch

-- use default method if none specified
if (method = empty) then put "Sort" into method

-- get a unique name for temporary list
put uniqList("listSort") into list

-- create list
get alist(new, list)
if (it = empty) then

  -- set sorting rules
  get alist(setattribute, list, "compare", compare)
  if (it = empty) then

    -- insert data
    get alist(add, list, data, separator)

    if (presorted = true) then
      get alist(setattribute, list, sorted, true)
    end if

    if (it = empty) then
      -- sort list and get results
      get alist(method, list)
      if (it = empty) then
        put alist(get, list, separator) into data
        get alist(error)
      end if
    end if
  end if
end if

-- dispose of temporary list
put alist(dispose, list) into junk

-- report any errors and return
if (it Γëá empty) then
  answer "listSort: " & errorstring(it)
  exit listSort
end if

return data
end listSort

-- return a name for a unique list
function uniqList template
global _uniqListCnt

if (_uniqListCnt = empty) then put 0 into _uniqListCnt
else add 1 to _uniqListCnt
return template & _uniqListCnt
end uniqList

-----------------------------------------------------------------------
-- Sort data using a binary tree. Returns the sorted data, or
-- empty if error.
-- Parameters:
--   data      The data to sort
--   compare   Rules for comparing items
--   separator Character separating data items
--   presorted If true, advises sort function that data are already
--             nearly sorted.
-----------------------------------------------------------------------
function treeSort data, compare, separator, presorted
set cursor to watch
-- get a unique name for temporary tree
put uniqTree("treeSort") into tree

-- create tree
if (presorted = true) then
  get btree(new, tree, compare, splay) -- splay trees are coming soon
else
  get btree(new, tree, compare)
end if

if (it = empty) then

  -- insert data into tree
  get btree(insert, tree, data, empty, separator)

  -- traverse tree
  if (it = empty) then
    put btree(inorder, tree, false, separator) into data
    get alist(error)
  end if
end if

-- dispose of temporary tree
put btree(dispose, tree) into junk

-- report any errors and return
if (it <> empty) then
  answer "treeSort: " & errorstring(it)
  exit treeSort
end if

return data
end treeSort

-- return a name for a unique tree
function uniqTree template
global _uniqTreeCnt

if (_uniqTreeCnt = empty) then put 0 into _uniqTreeCnt
else add 1 to _uniqTreeCnt
return template & _uniqTreeCnt
end uniqTree

-------------------------------------------------------------------
-- Radio button handling using ArrayList.
-- An auxillary list "_allRadioGroups" contains a list of all
-- radio buttons groups. This list is used to dispose of all
-- radio button groups when the endRadio handler is called.
-- A radio button group is stored in an ArrayList with the
-- name of the group; every item in this list corresponds to
-- the name of a button.
-- Handlers:
-- initRadio     call before using any of the radio button routines
-- endRadio      call when completely finished using the routines
-- newRadio      create a new radio button group
-- disposeRadio  dispose of a radio button group
-- clickRadio    click a radio button
-- selectedRadio return name of selected button
-------------------------------------------------------------------

-- Initialize radio buttons handlers; returns error number if error
function initRadio
get alist(new, "_allRadioGroups")
if (it Γëá empty) then return it
get alist(setattribute, "_allRadioGroups", sorted, true)
if (it Γëá empty) then return it
get alist(setattribute, "_allRadioGroups", compare, ignorecase)
if (it Γëá empty) then return it
return(empty)
end initRadio

-- End radio button handlers; returns error number if error
function endRadio
-- dispose of all groups of radio buttons
put alist(get, "_allRadioGroups") into list
if (alist(error) Γëá empty) then return alist(error)
repeat with i=1 to the number of items in list
  get alist(dispose, item i of list)
  if (it Γëá empty) then return it
end repeat
-- dispose of master list of radio buttons
get alist(dispose, "_allRadioGroups")
return it
end endRadio

-- Group is the name of a group; buttons is a string containing
-- the names of buttons in the group; where is either "card" or
-- "background". The first button in theButtons becomes hilited.
-- Empty is returned if succesful, otherwise an error code is returned.
function newRadio group, where, theButtons

-- create and add group to list of radio button groups
get alist(new, group)
if (it Γëá empty) then return it
get alist(setattribute, group, compare, ignorecase)
if (it Γëá empty) then return it
get alist(add, "_allRadioGroups", group)
if (it Γëá empty) then return it

-- build a list of buttons in the group
repeat with i=1 to the number of items of theButtons
  put where & " button " & quote before item i of theButtons
  put quote after item i of theButtons
end repeat

-- add all the buttons to the group
get alist(add, group, theButtons, ",")
if (it Γëá empty) then return it

-- hilite first button
set hilite of item 1 of theButtons to true

-- unhilite all other buttons
repeat with i=2 to the number of items of theButtons
  set hilite of item i of theButtons to false
end repeat

end newRadio

-- Dispose of the named radio button group.
-- The list containing the group is disposed of and removed from the
-- "_allRadioGroups" list.
-- Empty is returned if succesful, otherwise an error code is returned.
function disposeRadio group
-- Remove entry from the list of all radio button groups
get alist(search, "_allRadioGroups", group)
get alist(delete, "_allRadioGroups" & "[" & it & "]")
if (it Γëá empty) then return it
-- Dispose of the group
return alist(dispose, group)
end disposeRadio

-- Click on the button in the group.
-- The first button is always the button currently hilited, which
-- means we only have to set the hilite property of two buttons:
-- the button being hilited and the button being unhilited.
on clickRadio group, theButton

  -- get index to button
  put alist(search, group&"[2…]", theButton) into index
  if (index = empty) then exit clickRadio

  -- swap the locations of the buttons so hilited button is first
  put alist(get, group&"[1]") into current
  get alist(set, group&"[1]", theButton)
  get alist(set, group&"["&index&"]", current)

  -- unhilite current button and hilite clicked button
  set hilite of current to false
  set hilite of theButton to true
end clickRadio

-- Return the currently hilited button in the group
function selectedRadio group
return alist(get, group&"[1]")
end selectedRadio