module Citems (citems) where

import Tcl

-- This example uses a mixture of TclHaskell and Tcl code
-- taken from the Tcl widgets demos

data Position = GUIRef Pos
data Pos      = Pos Int Int


citems = 
     do tcl_ ["proc ci_bmp nm {file join @images $nm.bmp}"]
        w <- window []
        title w "Canvas Item Demonstration"
        l   <- label w [font "Helvetica 14", justify LeftJ,
                        "wraplength" %% "5i", text msg]
	packAdd l [packV]

        f   <- frame w []
	packAdd f [packV,fillXY,expand True]

        c   <- canvas w  [scrollregion ((0,0),(1200,960)),
                          relief Sunken, borderwidth 2,
                          width  600, height 400]

        vs  <- vscroll c []
        hs  <- hscroll c []
	gridAdd c (0,0) [ginFrame f,widthX 1,heightY 1,gfillXY]
	gridAdd vs (1,0) [ginFrame f,widthX 1,heightY 1,gfillXY]
	gridAdd hs (0,1) [ginFrame f,widthX 1,heightY 1,gfillXY]
        tcl_ ["grid rowconfig",wpath f,"0 -weight 1 -minsize 0"]
        tcl_ ["grid columnconfig",wpath f,"0 -weight 1 -minsize 0"]
       
        -- Display a 3x3 rectangular grid.
        
        crectangle c (0,0) (1200,960) [width 2]
        cline      c [(0,320),(1200,320)] [width 2] 
        cline      c [(0,640),(1200,640)] [width 2]
        cline      c [(400,0), (400,960)] [width 2]
        cline      c [(800,0), (800,960)] [width 2]
	return ()


        -- Set up the demos within each of the areas of the grid.
        
        ctext c (200,8) [text "Lines", anchor N]
        l1 <- cline c l1coords [width 8, fill "blue", tags ["item"],
                                "cap" %% "butt", "join" %% "miter"]
        l2 <- cline c l2coords ["arrow" %% "last", tags ["item"]]
        l3 <- cline c l3coords ["arrow" %% "both", tags ["item"]]

        l4 <- cline c l4coords [width 3, fill "red", tags ["item"]]
        l5 <- cline c l5coords [width 20, "arrow" %% "both",
                                "arrowshape" %% "{15 15 7}", tags ["item"], 
                                "stipple" %% "[ci_bmp gray25]"]
        l6 <- cline c l6coords [width 20, "cap" %% "round",
                                "join" %% "round", tags ["item"]]

        ctext c (600,8) [text "Curves (smoothed lines)", anchor N]
        c1 <- cline c c1coords ["smooth" %% "on", fill "blue", tags ["item"]]
        c2 <- cline c c2coords ["smooth" %% "on", "arrow" %% "both", 
                                                    width 3, tags ["item"]]
        c3 <- cline c c3coords ["smooth" %% "on", width 12,
                                "cap" %% "round", fill "red", tags ["item"],
                                         "stipple" %% "[ci_bmp gray25]"]
        
        ctext c (1000,8) [text "Polygons", anchor N]
        p1 <- cpoly c p1coords [fill "green", outline "black", width 4,
                                tags ["item"]]
        p2 <- cpoly c p2coords ["smooth" %% "on", fill "red", tags ["item"]]
        p3 <- cpoly c p3coords ["stipple" %% "[ci_bmp gray25]",
                                outline "black", tags ["item"]]

        ctext c (200,328) [text "Rectangles", anchor N]
        r1 <- crectangle c (40,380) (160,500) [outline "red", tags ["item"]
                                                 ,width 12]
        r2 <- crectangle c (20,540) (180,620) [fill "green",tags ["item"]]
        r3 <- crectangle c (240,400) (360,600) [fill "blue", tags ["item"],
                                              "stipple" %% "[ci_bmp gray25]"]

        ctext c (600,328) [text "Ovals", anchor N]
        o1 <- coval c (440,380) (560,500) [outline "red", width 12,
                                            tags ["item"]]
        o2 <- coval c (420,540) (580,620) [fill "green", tags ["item"]]
        o3 <- coval c (640,400) (760,600) ["stipple" %% "[ci_bmp gray25]",
                                                  fill "blue", tags ["item"]]

        ctext c (1000,328) [text "Text", anchor N]
        crectangle' c "24.4c 8.9c" "24.6c 9.1c" []
        t1 <- ctext' c "24.5c 9c" [anchor N, font font1, width 160,
                                                   text t1msg, tags ["item"]]
        crectangle' c "27.4c 10.9c" "27.6c 11.1c" []
        t2 <- ctext' c "27.5c 11c" [anchor W, font font1, fill "blue",
                                 text t2msg, justify CenterJ, tags ["item"]]
        crectangle' c "26.9c 13.9c" "27.1c 14.1c" []
        t3 <- ctext' c "27c 14c" [font font2, anchor C, fill "red", 
                            text t3msg, "stipple" %% "gray50", tags ["item"]]

        ctext c (200,648) [text "Arcs", anchor N]
        a1 <- carc' c "0.5c 18c" "7c 21c" [fill "green", outline "black",
                                       "start" %% "45", "extent" %% "270", 
                                        "style" %% "pieslice", tags ["item"]]

        a2 <- carc' c "6.5c 18c" "9.5c 21c" [outline "blue", "width" %% "4m",
                                         "outlinestipple" %% "[ci_bmp gray25]",
                                         "style" %% "arc", "start" %% "-135",
                                            "extent" %% "270", tags ["item"]]
        a3 <- carc' c "0.5c 21c" "9.5c 25c" ["width" %% "4m", outline "red",
                            fill "", "style" %% "pieslice", "start" %% "225", 
                                            "extent" %% "-90", tags ["item"]]
        a4 <- carc' c "5.5c 21.5c" "9.5c 24.5c" [fill "blue", "width" %% "4m",
                             outline "", "style" %% "chord", "start" %% "45",
                                            "extent" %% "270", tags ["item"]]

        ctext' c "16c 17.2c" [text "Bitmaps", anchor N]
        b1 <- cbitmap' c "14c 21c" ["bitmap" %% "[ci_bmp face]",
                                                        tags ["item"]]
        b2 <- cbitmap' c "18c 19.5c" ["bitmap" %% "[ci_bmp noletter]",
                                                        tags ["item"]]
        b3 <- cbitmap' c "18c 22.5c" ["bitmap" %% "[ci_bmp letters]",
                                                        tags ["item"]]

        ctext' c "25c 17.2c" [text "Windows", anchor N]
        but <- button w [text "Press Me",command (butPress c "red")]
        w1  <- cwindow' c "22c 19c" but [anchor NW, tags ["item"]]

        ent <- entry w [width 20, relief Sunken]
        setEntry ent "Edit this text"
        w2  <- cwindow' c "22c 22c" ent [anchor NW, tags ["item"]]

        vsc <- vscale w [sca_from 0, sca_to 100,
                         sca_length 240,sliderlength 10,
                         width 20,tickinterval 0]

        w3  <- cwindow' c "28.5c 17.5c" vsc [anchor N, tags ["item"]]
        ctext' c "22c 18.9c" [text "Button:", anchor SW]
        ctext' c "22c 21.9c" [text "Entry:", anchor SW]
        ctext' c "3.5c 18.4c" [text "Scale:", anchor S]

        rf  <- newState (Pos 0 0)

        bindxy c "<3>"          (scan_mark c rf)
        bindxy c "<B3-Motion>"  (scan_to c rf)

        tcl_ [wpath c,"bind item <Any-Enter> \"itemEnter\""]
        tcl_ [itemEnter c]
        tcl_ [wpath c,"bind item <Any-Leave> \"itemLeave\""]
        tcl_ [itemLeave c]

        tcl_ ["bind",wpath c,"<1> \"itemStartDrag %x %y\""]
        tcl_ [itemStartDrag c] 
        tcl_ ["bind",wpath c,"<B1-Motion> \"itemDrag %x %y\""]
        tcl_ [itemDrag c]
       
        return ()
     where

        scan_mark c rf (x,y) = 
             do scanMark c x y
                writeState rf (Pos x y)
                return ()
        
        scan_to c rf (x',y') = 
             do (Pos x y) <- readState rf
		scanDrag c (2*x-x') (2*y-y')
                return ()


        butPress c col = do t <- ctext' c "25c 18.1c" [text "Ouch!!", fill col,
                                                       anchor N]
                            let wp = wpath c
			    after 500 (destroy t)
                            return()
                        
l1coords,l2coords,l3coords,l4coords,l5coords,l6coords :: [Coord]
l1coords = [(40,40),(120,40),(40,160),(120,160)]
l2coords = [(186,40),(186,160)]
l3coords = [(253,40),(253,40)]
l4coords = [(200,240),(360,240),(360,40),(320,40),(320,192),(352,192),(352,48),(328,48),(328,184),(344,184),(344,56),(336,56),(336,176)]
l5coords = [(40,200),(280,200),(280,280),(360,280)]
l6coords = [(40,280),(70,232),(100,280),(130,232),(160,280)]

c1coords,c2coords,c3coords :: [Coord]
c1coords = [(440,160),(460,40),(540,40),(560,160)]
c2coords = [(620,40),(780,60),(620,180),(780,160)]
c3coords = [(480,240),(540,180),(660,300),(720,240),(660,180),(540,300),(480,240)]

p1coords,p2coords,p3coords :: [Coord]
p1coords = [(840,40),(900,70),(960,40),(930,100),(960,160),(900,130),(840,160),(870,100)]
p2coords = [(1000,160),(1000,160),(1000,40),(1040,40),(1080,160),(1120,40),(1160,40),(1160,160),(1160,160)]
p3coords = [(880,180),(1000,180),(1000,270),(1120,270),(1120,210),(960,210),(960,240),(1040,240),(1040,300),(880,300)]

t1msg = unlines ["A short string of text, word-wrapped, justified left,"
                ," and anchored north (at the top). The rectangles show"
                ," the anchor points for each piece of text."]
t2msg = unlines ["Several lines,\n each centerd\nindividually,\nand all "
                ,"anchored\n at the left edge."]
t3msg = "Stippled characters"
                


font1 = "Helvetica 12"
font2 = "Helvetica 24 bold"

msg = "This window contains a canvas widget with examples of the various kinds of items supported by canvases.  The following operations are supported:\n  Button-1 drag:\tmoves item under pointer.\n  Button-3 drag:\trepositions view.\n"


itemEnter c = unlines
        ["proc itemEnter {} {"  
        ,"      set c " ++ wpath c
        ,"      global restoreCmd"
        
        ,"      set type [$c type current]"
        ,"      if {$type == \"window\"} {"
        ,"         set restoreCmd {}"
        ,"         return"      
        ,"      }"

        ,"      if {$type == \"bitmap\"} {"
        ,"         set bg [lindex [$c itemconf current -background] 4]"
        ,"         set restoreCmd [list $c itemconfig current -background $bg]"
        ,"         $c itemconfig current -background SteelBlue2"
        ,"         return"
        ,"      }"

        ,"      set fill [lindex [$c itemconfig current -fill] 4]"
        ,"      if {(($type == \"rectangle\") || ($type == \"oval\") ||"
        ,"           ($type == \"arc\")) && ($fill == \"\")} {"
        ,"         set outline [lindex [$c itemconfig current -outline] 4]"
        ,"         set restoreCmd \"$c itemconfig current -outline $outline\""
        ,"         $c itemconfig current -outline SteelBlue2"
        ,"      } else {"
        ,"         set restoreCmd \"$c itemconfig current -fill $fill\""
        ,"         $c itemconfig current -fill SteelBlue2"
        ,"      }"
        ,"}"
        ]

itemLeave c = unlines
        ["proc itemLeave {} {"
        ,"      global restoreCmd"
        ,"      set c " ++ wpath c
        
        ,"      eval $restoreCmd"
        ,"}"
        ]

itemStartDrag c = unlines
        ["proc itemStartDrag {x y} {"
        ,"      set c " ++ wpath c
        ,"      global lastX lastY"
        ,"      set lastX [$c canvasx $x]"
        ,"      set lastY [$c canvasy $y]"
        ,"}"
        ]

itemDrag c = unlines
        ["proc itemDrag {x y} {"
        ,"      set c " ++ wpath c
        ,"      global lastX lastY"
        ,"      set x [$c canvasx $x]"
        ,"      set y [$c canvasy $y]"
        ,"      $c move current [expr $x-$lastX] [expr $y-$lastY]"
        ,"      set lastX $x"
        ,"      set lastY $y"
        ,"}"
        ]
