adamc@916
|
1 fun draggableList title items =
|
adamc@916
|
2 itemSources <- List.mapM source items;
|
adamc@916
|
3 draggingItem <- source None;
|
adamc@916
|
4 return <xml>
|
adamc@916
|
5 <h2>Great {[title]}</h2>
|
adamc@916
|
6 <ul>
|
adamc@916
|
7 {List.mapX (fn itemSource => <xml>
|
adam@1784
|
8 <li onmousedown={fn _ => set draggingItem (Some itemSource)}
|
adam@1784
|
9 onmouseup={fn _ => set draggingItem None}
|
adam@1784
|
10 onmouseover={fn _ => di <- get draggingItem;
|
adam@1784
|
11 case di of
|
adam@1784
|
12 None => return ()
|
adam@1784
|
13 | Some di => original <- get di;
|
adam@1784
|
14 movedOver <- get itemSource;
|
adam@1784
|
15 set di movedOver;
|
adam@1784
|
16 set itemSource original;
|
adam@1784
|
17 set draggingItem (Some itemSource)}>
|
adamc@918
|
18 <dyn signal={Monad.mp cdata (signal itemSource)}/>
|
adamc@916
|
19 </li></xml>) itemSources}
|
adamc@916
|
20 </ul>
|
adamc@916
|
21 </xml>
|
adamc@916
|
22
|
adamc@916
|
23 fun main () =
|
adamc@916
|
24 bears <- draggableList "Bears" ("Pooh" :: "Paddington" :: "Rupert" :: "Edward" :: []);
|
adamc@916
|
25 beers <- draggableList "Beers" ("Budvar" :: "Delirium Tremens" :: "Deuchars" :: []);
|
adamc@916
|
26 boars <- draggableList "Boars" ("Sus scrofa scrofa"
|
adamc@916
|
27 :: "Sus scrofa ussuricus"
|
adamc@916
|
28 :: "Sus scrofa cristatus"
|
adamc@916
|
29 :: "Sus scrofa taiwanus" :: []);
|
adamc@917
|
30 return <xml>
|
adamc@917
|
31 <head>
|
adamc@917
|
32 <link rel="stylesheet" type="text/css" href="../../dragList.css"/>
|
adamc@917
|
33 </head>
|
adamc@917
|
34 <body>
|
adamc@917
|
35 {bears}
|
adamc@917
|
36 {beers}
|
adamc@917
|
37 {boars}
|
adamc@917
|
38 </body>
|
adamc@917
|
39 </xml>
|