home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 7 / Apprentice-Release7.iso / Environments / Clean 1.2.4 / IO Examples / Simple DataBase / database.icl < prev    next >
Encoding:
Text File  |  1997-05-16  |  18.8 KB  |  438 lines  |  [TEXT/3PRM]
  1. module database    //    Small database program to manipulate a simple database
  2. import StdEnv
  3. import deltaEventIO, deltaDialog, deltaIOSystem, deltaMenu, deltaWindow, deltaFont
  4. import deltaPicture, deltaIOState, deltaFileSelect, deltaControls, deltaSystem
  5. import listextensions
  6.  
  7. ::    *IO            :==    IOState  DataBase                     // Synonym for IOState (see deltaEventIO)
  8. ::    *DataBase    :==    (State, Files)                        // State contains all relevant info
  9. ::    Record        :==    [ String ]                            // [Content]
  10. ::    Descriptor  :== [ String ]                            // [Fieldname]
  11. ::    State        =    {    records        :: [Record]            // All records
  12.                     ,    descriptor    :: Descriptor        // All fieldnames
  13.                     ,    selection    :: Int                // Indicating current record selected
  14.                     ,    query        :: Record            // Record to look for
  15.                     ,    name        :: String            // Name of database
  16.                     ,    editinfoid    :: DialogItemId        // Id of info about use of editdialog (query or record)
  17.                     ,    fw            :: Int                // Max width of field contents
  18.                     ,    dw            :: Int                // Max width of descriptor fields
  19.                     }
  20. ::    InfoFont    =    {    font        :: Font                // The font which is used
  21.                     ,    width        :: Int                // Its widest character
  22.                     ,    height        :: Int                // Its line height
  23.                     }
  24.  
  25. MinDbDomainSize :== (100,1)                                // Minimal size of recordwindow
  26. CharsInInputBox :== 20                                    // Input width (number of characters)
  27. InputBoxWidth   :== Pixel (CharsInInputBox*DfFont.width)// Width of boxes in fields, queries and field names
  28.  
  29. DontCareId      :== 0
  30. RecordWindowId    :== 0                                    // Id of window in which the records are shown 
  31. EdDialogId        :== 0;    FieldDialogId    :== 1            // Ids of main dialogs used
  32.  
  33. Replace        :== True                                    // Replace current selection when adding new record
  34. Separator    :==    ": "                                    // Separates field names and contents
  35.  
  36. DbFont        =:    {font = f, width = maxwidth, height = ascent+descent+leading} 
  37. where                                                    // Global graph def: font used in this database
  38.     (ascent,descent,maxwidth,leading)    = FontMetrics f
  39.     (_,f)                                = SelectFont "courier" [] 10
  40.  
  41. DfFont        =:    {font = f, width = maxwidth, height = ascent+descent+leading}
  42. where                                                    // Global graph def: default font (in dialogs)
  43.     (ascent,descent,maxwidth,leading)    = FontMetrics f
  44.     (_,f)                                = SelectFont name styles length
  45.     (name,styles,length)                = DefaultFont
  46.  
  47. Start :: *World -> *World
  48. Start world
  49. #    (events,world)    = OpenEvents world
  50.     (files, world)    = openfiles  world
  51.     ((_,finalfiles),finalevents)
  52.                     = StartIO [MenuSystem [menu]] (initState,files) initIO events
  53.     world            = CloseEvents finalevents world
  54.     world            = closefiles  finalfiles  world
  55. =    world
  56. where
  57.      menu            = PullDownMenu DontCareId "Commands" Able
  58.                          [    MenuItem DontCareId    "Show Records"       (Key 'r') Able ShowRecords
  59.                          ,    MenuItem DontCareId    "Edit..."           (Key 'e') Able ShowEditDialog
  60.                          ,    MenuItem DontCareId    "Change Set Up..." (Key 'u') Able ShowFieldDialog
  61.                          ,    MenuItem DontCareId    "Read new..."       (Key 'o') Able (\s io->seqIO initIO (s, seq closeIO io))
  62.                          ,    MenuItem DontCareId    "Save As..."       (Key 's') Able SaveRecords
  63.                          ,    MenuSeparator
  64.                          ,    MenuItem DontCareId    "Quit"               (Key 'q') Able Quit
  65.                          ]
  66.     initIO            = [    ReadDataBase, ShowRecords, ShowEditDialog        ]
  67.     closeIO            = [ CloseWindows [RecordWindowId], closeDbDialogs    ]
  68.     initState        = {    records=[],descriptor=[],selection=0,query=[],name="",editinfoid=0,fw=0,dw=0 }
  69.  
  70. //    The CallBack and initialisation Functions of the menu:
  71.  
  72. ReadDataBase :: DataBase IO -> (DataBase, IO)
  73. ReadDataBase db io
  74. #    (done,dbname,(state, files),io)    = SelectInputFile db io
  75. |    not done                = ((state,files),io)
  76. #    (open,dbfile,files)        = fopen dbname FReadText files
  77. |    not open                = ((state,files),Beep io)
  78. #    (descr,dbfile)            = FReadDescr dbfile
  79.     (recs, dbfile)            = FReadRecords (inc (length descr)) dbfile    // lines = length descr + empty line
  80.     (close,files)            = fclose dbfile files
  81. |    not close                = ((state,files),Beep io)
  82. |    otherwise                = (({state & records=recs,descriptor=descr,query=repeatn (length descr) "",selection=0,name=dbname,
  83.                                          fw=MaxWidth DbFont.font (flatten recs),dw=MaxWidth DbFont.font descr},files)
  84.                               ,io
  85.                               )
  86. where
  87.     FReadDescr file
  88.     #    (nroffields,file)    = FReadStrippedLine file
  89.         (descr,file)        = seqList (repeatn (toInt nroffields) FReadStrippedLine) file
  90.     =    (descr,file)
  91.     
  92.     FReadRecords nroflines file
  93.     |    sfend file            = ([], file)
  94.     #    ([_:record],file)    = seqList (repeatn nroflines FReadStrippedLine) file
  95.         (records,    file)    = FReadRecords nroflines file
  96.     =    ([record : records], file)
  97.     
  98.     FReadStrippedLine file
  99.     #    (line, file)        = freadline file
  100.     =    (line%(0,size line - 2),file)        // strip "\n"
  101.  
  102. ShowRecords :: DataBase IO -> (DataBase, IO)
  103. ShowRecords (state=:{records,descriptor,dw,name}, files) io
  104. =    ((state,files),OpenWindows [window] io)
  105. where
  106.     window = ScrollWindow RecordWindowId (5,5) namewithoutdirectories
  107.               (ScrollBar (Thumb left) (Scroll DbFont.width)) (ScrollBar (Thumb top) (Scroll DbFont.height))
  108.               domain MinDbDomainSize (right - left,bottom - top)
  109.               UpdateRecordWindow    [Mouse Able MouseSelectItem]
  110.     namewithoutdirectories        = toString (last (splitby DirSeparator (fromString name)))
  111.     ((left,top),(right,bottom)) = domain
  112.     domain                        = DbPictureDomain state 0 (max (length records) 1)
  113.  
  114. ShowEditDialog    :: DataBase IO -> (DataBase, IO)
  115. ShowEditDialog (state=:{descriptor=descr,records=recs,selection},files) io 
  116. #    io    = OpenDialog editDialog    io
  117.     io    = SetTextFields infoid infostring descr (if (isEmpty recs) [] (recs!!selection))    io
  118. =    (({state & editinfoid = infoid},files), io)
  119. where
  120.     infostring    = "Current Record Number: "+++toString selection
  121.     editDialog    = CommandDialog EdDialogId "Edit Record" [] addId dialogitems
  122.     dialogitems    = [        DynamicText infoid Left InputBoxWidth ""    ]
  123.                   ++    flatten [inputfield sid eid field \\ field <- descr & eid <- [0..] & sid <- [length descr..]]
  124.                   ++
  125.                   [        DialogButton dispQId (Below (length descr - 1))    "DisplQ"        Able DisplQuery
  126.                   ,        DialogButton setQId     (RightTo dispQId)            "SetQ"            Able SetQuery
  127.                   ,        DialogButton srchQId (RightTo setQId)            "SearchQ"         Able Search
  128.                   ,        DialogButton slctQId (RightTo srchQId)            "SelectAllQ"    Able SelectAll
  129.                   ,        DialogButton replId     (Below dispQId)            "Replace"        Able (AddRecord Replace)
  130.                   ,        DialogButton delId     (RightTo replId)            "Delete"         Able DeleteRecord
  131.                   ,        DialogButton addId     (RightTo delId)            "Add"             Able (AddRecord    (not Replace))
  132.                   ,        DialogButton sortId     (RightTo addId)            "Sort"            Able Sort
  133.                   ]
  134.     
  135.     inputfield sid eid field
  136.     =    [StaticText sid Left field, EditText eid pos InputBoxWidth 1 ""]
  137.     where 
  138.         pos       = case eid of 0 -> XOffset sid offset; else -> Below (dec eid)
  139.         offset = Pixel (DfFont.width + MaxWidth DfFont.font descr - MaxWidth DfFont.font [field])
  140.     
  141.     [infoid,dispQId,setQId,srchQId,slctQId,replId,delId,addId,sortId:_] = [2*(length descr)..]
  142.  
  143. ShowFieldDialog :: DataBase IO -> (DataBase, IO)
  144. ShowFieldDialog db=:({descriptor=d},_) io 
  145. |    isEmpty d    = inputdialog "Give first field" InputBoxWidth (\input->FieldChangeIO (add (-1) input)) db io
  146. |    otherwise    = (db,OpenDialog fielddialog (CloseDialog EdDialogId io))
  147. with
  148.     fielddialog    = CommandDialog FieldDialogId "Change Set Up" [] addId 
  149.                     [StaticText DontCareId Left "Select Field...", 
  150.                       RadioButtons selectId Left (Columns 1) firstRadioId (radioitems firstRadioId d),
  151.                      DialogButton deleteId Left "Delete" Able (DeleteField getselectedfield),
  152.                      DialogButton moveId (RightTo deleteId) "Move" Able (MoveField getselectedfield),
  153.                      DialogButton renameId Left "Rename" Able (RenameField getselectedfield),
  154.                      DialogButton addId  (Below moveId) "Add New" Able (AddField getselectedfield)]
  155.     
  156.     getselectedfield dialoginfo = GetSelectedRadioItemId selectId dialoginfo - firstRadioId
  157.     
  158.     [deleteId,moveId,renameId,addId,selectId,firstRadioId:_] = [0..]
  159.  
  160. SaveRecords :: DataBase IO -> (DataBase, IO)
  161. SaveRecords db=:({name,descriptor,records},_) io
  162. #    (done,dbname,db,io)      = SelectOutputFile "Save As: " name db io
  163. |    not done                = (db, io)
  164. #    (state,files)            = db
  165.     (open,dbfile,files)     = fopen dbname FWriteText files
  166. |    not open                = ((state,files), Beep io)
  167. #    (close,files)             = fclose (seq (writedescriptor++writerecords) dbfile) files
  168. |    not close                = ((state, files), Beep io)
  169. |    otherwise                = ((state, files), io)
  170. where
  171.     writedescriptor            = [fwritei (length descriptor), FWriteRecord descriptor]
  172.     writerecords            = [FWriteRecord rec \\ rec <- records]
  173.     FWriteRecord rec        = fwrites (foldl (+++) "\n" (map (\field -> field +++ "\n") rec))
  174.  
  175. Quit :: DataBase IO -> (DataBase, IO)
  176. Quit database io = (database, QuitIO io)
  177.  
  178. // Field set up changes
  179.  
  180. FieldChangeIO :: (State -> State) DataBase IO -> (DataBase,IO)
  181. FieldChangeIO changefun (state,files) io = UpdateDbDomain (changefun state,files) (closeDbDialogs io)
  182.     
  183. AddField :: (DialogInfo -> Int) DialogInfo DataBase IO -> (DataBase, IO)
  184. AddField getfield dialoginfo db=:(state,files) io 
  185. =    inputdialog infotext InputBoxWidth (\input->FieldChangeIO (add fieldname input)) db io
  186. where
  187.     infotext   = "Add after '"+++state.descriptor!!fieldname+++"' new field"
  188.     fieldname  = getfield dialoginfo
  189.  
  190. RenameField :: (DialogInfo -> Int) DialogInfo DataBase IO -> (DataBase, IO)
  191. RenameField getfield dialoginfo db=:(state,files) io 
  192. =    inputdialog infotext InputBoxWidth (\input->FieldChangeIO (rename fieldtorename input)) db io
  193. where
  194.     infotext       = "Rename '"+++state.descriptor!!fieldtorename+++"' to"
  195.     fieldtorename  = getfield dialoginfo
  196.  
  197. MoveField :: (DialogInfo -> Int) DialogInfo DataBase IO -> (DataBase, IO)
  198. MoveField getfield dialoginfo db=:({descriptor=d},_) io
  199. =    (db,OpenDialog movedialog io)
  200. where
  201.     fieldtomove = getfield dialoginfo
  202.     movedialog  
  203.     =    CommandDialog moveDialogId "Move Field" [] okId 
  204.             [    StaticText     infoId        Left ("Move '"+++(d!!fieldtomove)+++ "' before: ")
  205.             ,    RadioButtons selectId    Left (Rows (inc (length d))) firstRadioId (radioitems firstRadioId (d++[""]))
  206.             ,    DialogButton cancelId    Left Cancel Able cancel
  207.             ,    DialogButton okId        (RightTo cancelId) "Move" Able (ok (move fieldtomove))
  208.             ]
  209.     
  210.     [moveDialogId,cancelId,okId,infoId, selectId,firstRadioId:_] = [0..]     
  211.     
  212.     ok mvf dlginfo s io 
  213.     =    FieldChangeIO (mvf destinationfield) s (CloseDialog moveDialogId io)
  214.     where
  215.         destinationfield = GetSelectedRadioItemId selectId dlginfo - firstRadioId
  216.         
  217. DeleteField :: (DialogInfo -> Int) DialogInfo DataBase IO -> (DataBase, IO)
  218. DeleteField getfield dialoginfo db io 
  219. =    warn ["Are you sure?"] (FieldChangeIO (delete (getfield dialoginfo))) db io
  220.     
  221. add afterfield fieldname state=:{records=rs,descriptor=d,query=q,dw}
  222. =    {state & records=map (ins "") rs,descriptor=ins fieldname d,query=ins "" q,dw=descrwidth}
  223. where
  224.     ins x ys   = insertAt (inc afterfield) x ys
  225.     descrwidth = max (MaxWidth DbFont.font [fieldname]) dw
  226.  
  227. rename selectedfield newfieldname s=:{descriptor=d} 
  228. =    {s & descriptor=newdescr,dw=MaxWidth DbFont.font newdescr}
  229. where
  230.     newdescr = updateAt selectedfield newfieldname d
  231.     
  232. move sf df s=:{records=rs,descriptor=d,query=q}
  233. =    {s & records=map (moveinlist sf df) rs,descriptor=moveinlist sf df d,query=moveinlist sf df q}
  234.  
  235. delete i s=:{records=rs,descriptor=d,query=q} 
  236. =    {s & records=newrs,descriptor=newdescr,query=remove i q,dw=MaxWidth DbFont.font newdescr,fw=nfw}
  237. where
  238.     newrs    = map (remove i) rs
  239.     newdescr = remove i d
  240.     nfw      = MaxWidth DbFont.font (flatten newrs)
  241.  
  242. //    Handling the edit dialog
  243.  
  244. DisplQuery ::DialogInfo DataBase IO -> (DataBase, IO)
  245. DisplQuery info db=:({descriptor,query,editinfoid},_) io 
  246. =    (db,SetTextFields editinfoid "Query :" descriptor query io)
  247.  
  248. SetQuery ::DialogInfo DataBase IO -> (DataBase, IO)
  249. SetQuery info (state, files) io
  250. #    (nquery,io) = GetTextFields state.descriptor io
  251. =    (({state & query = nquery},files), io)
  252.  
  253. Search ::DialogInfo DataBase IO -> (DataBase, IO)
  254. Search  info database=:(state=:{records,query,selection=sel},files) io
  255. |    isEmpty found    = (database, Beep io)
  256. |    otherwise        = MakeSelectionVisible ({state & selection=nsel},files) (ChangeSelection state sel nsel io)
  257. where
  258.     nsel            = hd found
  259.     found            = [i \\ e <- el ++ bl & i <- [sel+1 .. length records - 1] ++ [0..] | QueryRecord query e]
  260.     (bl,el)            = splitAt (sel+1) records
  261.  
  262. QueryRecord :: Record Record -> Bool
  263. QueryRecord query e
  264. =    and [ EqPref qf f \\ f <- e & qf <- query ]
  265. where
  266.     EqPref pref name
  267.     |    size pref > size name    = False
  268.     |    otherwise                = pref == name%(0,size pref - 1)
  269.  
  270. SelectAll :: DialogInfo DataBase IO -> (DataBase, IO)
  271. SelectAll info database=:(state=:{records,query,selection,descriptor},files) io
  272. |    isEmpty recs    = (database, Beep io)
  273. #    io                = ChangeSelection state selection 0 io
  274.     io                = ChangeWindowTitle RecordWindowId selname io
  275. |    otherwise        = UpdateDbDomain (nstate,files) io
  276. where
  277.     recs            = filter (QueryRecord query) records
  278.     nstate            = {state & selection=0,records=recs,name=selname,fw=MaxWidth DbFont.font (flatten recs)}
  279.     selname            = "Select"
  280.  
  281. MakeSelectionVisible :: DataBase IO -> (DataBase,IO)
  282. MakeSelectionVisible db=:({records,selection,descriptor},_) io
  283. |    isEmpty records        = (db,io)
  284. |    selection_invisible    = ChangeScrollBar RecordWindowId (ChangeVThumb selthumb) db io1
  285. |    otherwise            = (db,io1)
  286. where
  287.     (((_,visibletop),(_,visiblebot)), io1)
  288.                         = WindowGetFrame RecordWindowId io
  289.     selection_invisible = selthumb < visibletop || selthumb >= visiblebot
  290.     selthumb             = toPicCo descriptor selection
  291.  
  292. DeleteRecord :: DialogInfo DataBase IO -> (DataBase, IO)
  293. DeleteRecord dialogInfo db=:(state=:{records=oldrecs,selection=index,descriptor,fw},files) io
  294. |    isEmpty oldrecs        = (db,Beep io)
  295. |    otherwise            = UpdateDbDomain (nstate,files) io
  296. where
  297.     newrecs                = remove index oldrecs
  298.     fieldwidth            = if recalcwidth (MaxWidth DbFont.font (flatten newrecs)) fw
  299.     recalcwidth            = fw == MaxWidth DbFont.font (oldrecs!!index)
  300.     nindex                = if (isEmpty newrecs) 0 (index mod length newrecs) 
  301.     nstate                = {state & records = newrecs, selection = nindex, fw = fieldwidth}
  302.  
  303. AddRecord :: Bool DialogInfo DataBase IO -> (DataBase, IO)
  304. AddRecord replace dialogInfo db=:(state=:{descriptor,selection,records=recs,fw},files) io
  305. |    isEmpty recs && replace    = (db,Beep io)
  306. |    otherwise                = UpdateDbDomain (nstate,files) io1
  307. where
  308.     (newrec,io1)            = GetTextFields descriptor io
  309.     (index,newrecs)            = insertindex (\a b -> a <= b) newrec (if replace (remove selection recs) recs)
  310.     fieldwidth                = if recalc (MaxWidth DbFont.font (flatten newrecs)) (max (MaxWidth DbFont.font newrec) fw)
  311.     recalc                    = replace && MaxWidth DbFont.font (recs!!selection) < fw
  312.     nstate                    = {state & records=newrecs,selection=index,fw=fieldwidth}
  313.  
  314. Sort :: DialogInfo DataBase IO -> (DataBase, IO)
  315. Sort dialogInfo (state=:{records=recs},files) io
  316. =    UpdateDbDomain ({state & records = sort recs},files) io
  317.  
  318. GetTextFields :: Descriptor IO -> (Record,IO)
  319. GetTextFields descr io
  320. =    ([GetEditText id dialogInfo \\ id <- [0..(length descr - 1)]],nio)
  321. where
  322.     (_,dialogInfo,nio) = GetDialogInfo EdDialogId io
  323.  
  324. SetTextFields :: Int String Descriptor Record IO ->IO
  325. SetTextFields infoid s d rec io
  326. =    ChangeDialog EdDialogId dialogchanges io
  327. where
  328.     dialogchanges = [ChangeDynamicText infoid s : [ChangeEditText id f \\ id <- [0.. length d - 1] & f <- rec]]
  329.  
  330. //    Handling mouse clicks in database window
  331.  
  332. MouseSelectItem    :: MouseState DataBase IO -> (DataBase, IO)
  333. MouseSelectItem ((_,mvpos), ButtonDown, _) (state=:{records,descriptor,selection}, files) io
  334. |    isEmpty records    = ((state, files), io)
  335. |    otherwise        = (({state & selection=index},files),ChangeSelection state selection index io)
  336. where
  337.     index            = toRecCo descriptor mvpos
  338. MouseSelectItem _ database io
  339.                     = (database, io)
  340.  
  341. //    Drawing utilities
  342.  
  343. DbPictureDomain :: State Int Int -> PictureDomain
  344. DbPictureDomain state=:{descriptor=d,records,dw,fw} fr to 
  345. |    (right-left,bottom-top) < MinDbDomainSize
  346.                                 = ((~whiteMargin,  0),(~whiteMargin+width,height))
  347. |    otherwise                    = ((left        ,top),(             right,bottom))
  348. where
  349.     (width,height)                = MinDbDomainSize
  350.     whiteMargin                    = DbFont.width
  351.     ((left,top),(right,bottom))    = (    (~whiteMargin                                            ,toPicCo d fr)
  352.                                   ,    (dw + MaxWidth DbFont.font [Separator] + fw + whiteMargin,toPicCo d to)
  353.                                   )
  354.  
  355. UpdateDbDomain :: DataBase IO -> (DataBase,IO)
  356. UpdateDbDomain db=:(state,files) io
  357. #    (db,io)    = ChangePictureDomain RecordWindowId (DbPictureDomain state 0 (max (length state.records) 1)) db io
  358.     (db,io)    = DrawInWindowFrame   RecordWindowId UpdateRecordWindow db io
  359.     (db,io)    = MakeSelectionVisible db io
  360. =    (db,io)
  361.  
  362. UpdateRecordWindow    :: UpdateArea DataBase -> (DataBase, [DrawFunction])
  363. UpdateRecordWindow domains db=:(state=:{records=recs,descriptor=descr,selection}, _) 
  364. =    (db,[SetFont DbFont.font : flatten (map Update domains)] ++ HiliteSelection state selection)
  365. where 
  366.     Update domain=:((_,top),(_,bottom))
  367.     |    isEmpty recs    = [EraseRectangle domain]
  368.     |    otherwise        = [EraseRectangle domain, MovePenTo (0,topofvisiblerecs) : map (DrawRec descr) (recs%(toprec,botrec))]
  369.     where
  370.         topofvisiblerecs= toPicCo descr toprec
  371.         toprec            = toRecCo descr top
  372.         botrec            = toRecCo descr (dec bottom)
  373.     
  374.     DrawRec descr rec 
  375.     =    seq (drawLine "" ++ flatten [drawLine (d +++ Separator +++ f) \\ d<-normwidth descr & f<-rec])
  376.     where
  377.         normwidth descr = [f +++ toString (spaces ((maxList (map (size ) descr)) - size f)) \\ f <- descr]
  378.         drawLine s      = [DrawString s,MovePen (~(FontStringWidth s DbFont.font),DbFont.height)]
  379.  
  380. ChangeSelection:: State Int Int IO -> IO
  381. ChangeSelection state=:{descriptor=descr,records,editinfoid} old new io
  382. #    io    = DrawInWindow RecordWindowId (HiliteSelection state old ++ HiliteSelection state new) io
  383.     io    = SetTextFields editinfoid infostring descr (records!!new) io
  384. =    io
  385. where
  386.     infostring = "Current Rec Nr: "+++toString new
  387.  
  388. HiliteSelection :: State Int -> [Picture -> Picture]
  389. HiliteSelection s i
  390. =    [ SetPenMode HiliteMode, FillRectangle (DbPictureDomain s i (inc i)), SetPenNormal, SetPenColour BlackColour ]
  391.     
  392. //    Switching between picture coordinates and indices in the list of records ('record coordinates')
  393.  
  394. toPicCo:: Descriptor Int -> Int
  395. toPicCo descr n = n * (inc (length descr) * DbFont.height)
  396.  
  397. toRecCo:: Descriptor Int -> Int
  398. toRecCo descr n = n / (inc (length descr) * DbFont.height)
  399.  
  400. // Various useful functions
  401.  
  402. closeDbDialogs io = seq (map CloseDialog [FieldDialogId,EdDialogId]) io 
  403.  
  404. radioitems firstid titles = [RadioItem id t Able (\ _ x -> x) \\ id <- [firstid..] & t <- titles]
  405.         
  406. MaxWidth font []   = 0
  407. MaxWidth font list = maxList (FontStringWidths list font)
  408.  
  409. // functions that should be library functions
  410.  
  411. seqIO fs    = seq (map uncurry fs)        // should be in deltaEventIO, will be obsolete with new IO-library
  412.  
  413.  
  414. Cancel        :==    "Cancel"
  415. OK            :==    "OK"
  416.  
  417. inputdialog name width fun s io
  418. =    (s,OpenDialog dialogdef io)
  419. where
  420.     dialogdef    = CommandDialog dlgId name [] okId
  421.                     [    StaticText nameId Left (name+++": "),EditText inputId (RightTo nameId) width 1 ""
  422.                     ,    DialogButton cancelId (Below inputId) Cancel Able cancel
  423.                     ,    DialogButton okId (RightTo cancelId) OK Able (ok fun)
  424.                     ]
  425.     ok fun dlginfo s io                        = fun (GetEditText inputId dlginfo) s (CloseDialog dlgId io)
  426.     [dlgId,nameId,inputId,cancelId,okId:_]    = [0..] 
  427.  
  428. warn info fun s io
  429. #    (choiceId,s,io)            = OpenNotice warningdef s io 
  430. |    choiceId == cancelId    = (s,io)
  431. |    otherwise                = fun s io
  432. where
  433.     warningdef                = Notice info (NoticeButton cancelId Cancel) [NoticeButton okId OK]
  434.     cancelId                = 0
  435.     okId                    = 1
  436.  
  437. cancel _ s io = (s, CloseActiveDialog io)
  438.