imports { import Common.CommonTypes hiding (Dirty (..)) import Common.CommonUtils import GHC.Float (formatRealFloat, FFFormat(FFFixed)) import Presentation.PresLayerTypes import Presentation.PresLayerUtils import Presentation.XprezLib import Presentation.XLatex hiding (bold) import Layout.LayTypes import Proxima.Wrap import Evaluation.DocumentEdit import List import Maybe import qualified Data.Map as Map import Data.Map (Map) import Evaluation.DocTypes (DocumentLevel (..)) import DocTypes_Generated import DocUtils_Generated import DocumentEdit_Generated import ProxParser import Sudoku hiding (fst3, snd3, thd3) } INCLUDE "PresentationAG_Generated.ag" SEM EnrichedDoc | RootEnr loc.pres = structural $ @choiceDoc.pres SEM ChoiceDoc | FormDoc loc.pres = structural $ @form.pres `withbgColor` lightBlue | TaskDoc loc.pres = structural $ @tasks.pres | SudokuDoc loc.pres = structural $ @sudoku.pres | TestDoc loc.pres = structural $ @test.pres SEM Form | Form loc.pres = structural $ -- col [ text "bla" , row [text "za", text "tralala"]] leftTopMargins 30 40 $ col [ text "Travel declaration form" , vSpace 5 , textField 400 @name.pres , vSpace 5 , textField 400 @faculty.pres , vSpace 10 , text "Expenses" `addPopupItems` [ ("Add expense", docUpd $ insertElementAtEnd (toClip newExpense) (@lhs.path++[2])) ] , @expenses.pres , vSpace 5 , row [ img "img/add.png" `withSize` (23,20) `withVRef` 10 `withMouseDown` insertElementAtEnd (toClip newExpense) (@lhs.path++[2]) , hSpace 5 , vRefHalf $ text "add expense" , empty `withHStretch` True , col [ empty `withSize` (120,2) `withbgColor` black , vSpace 5 , textField 120 (text $ showCurrency @expenses.total ++ " " ++ @baseCurrencyName) ] `withVRef` (10) ] , vSpace 15 , @currencies.pres `withFontSize_` (\fs -> (fs * 80) `div` 100) ] SEM List_Expense | List_Expense loc.pres = structural $ col $ intersperse (vSpace 5) @elts.press SEM Expense | Expense loc.pres = structural $ addCurrencyItems @lhs.allCurrencies @lhs.path $ row [ textField 400 @description.pres , hSpace 5 , textField 60 @amount.pres , hSpace 5 , textField 80 $ (text $ if null @lhs.allCurrencies then "" else fst $ index "Expense.pres" @lhs.allCurrencies @currencyIx) , hSpace 10 , textField 120 (text $ showCurrency @total ++ " " ++ @lhs.baseCurrencyName) -- Expense.total is total euro base currency amount for one expense ] `addPopupItems` [ ("Delete expense", docUpd $ deleteAt @lhs.path) , ("Move expense up", docUpd $ moveElementUp @lhs.path) , ("Move expense down", docUpd $ moveElementDown @lhs.path) ] SEM List_Currency [ | | ] | List_Currency loc.pres = structural $ col [ row $ intersperse (hSpace 5) @elts.press , vSpace 5 , row [ img "img/add.png" `withSize` (23,20) `withVRef` 10 `withMouseDown` addNewCurrency @lhs.path , hSpace 5 , vRefHalf $ text "add currency" ] ] SEM Currency | Currency loc.pres = structural $ col [ textField 120 @name.pres , vSpace 4 , textField 120 @euroRate.pres ] `addPopupItems` [ ("Change base currency to "++ @name.strVal , changeBaseCurrency @lhs.formPath @lhs.ix) ] ATTR List_Expense ConsList_Expense Expense [ baseCurrencyName : String | | ] ATTR List_Currency ConsList_Currency Currency [ formPath : Path | | ] SEM Form | Form loc.baseCurrencyName = if null @currencies.allCurrencies then "" else fst $ index "Form.baseCurrencyName" @currencies.allCurrencies @baseCurrency currencies.formPath = @lhs.path -- currency names and rates are put in synthesized attribute that is inherited to Expenses ATTR List_Currency ConsList_Currency Currency [ | | allCurrencies USE {++} {[]} : {[(String,Float)]} ] SEM Currency | Currency lhs.allCurrencies = [(@name.strVal, @euroRate.floatVal)] ATTR List_Expense ConsList_Expense Expense [ allCurrencies : {[(String,Float)]} | | ] SEM Form | Form expenses.allCurrencies = @currencies.allCurrencies ATTR List_Expense ConsList_Expense Expense [ | | total USE {+} {0} : {Float} ] SEM Expense | Expense loc.total = @amount.floatVal * (if null @lhs.allCurrencies then 0 else snd $ index "Expense.total" @lhs.allCurrencies @currencyIx) { addCurrencyItems currencies path pres = pres `addPopupItems` [ ("Change currency to "++name, docUpd $ setCurrencyIx path ix) | (ix, (name, _)) <- zip [0..] currencies ] addNewCurrency :: Path -> UpdateDoc Document ClipDoc addNewCurrency path = insertElementAtEnd newCurrency path newExpense = Expense (Description "") (Float_ 0) 0 newCurrency = Clip_Currency $ Currency (Description "new") (Float_ 0.0) changeBaseCurrency formPath newBase = docUpd $ updateAt formPath $ \clip -> case clip of Clip_Form (Form name faculty expenses oldBase listCurrency) -> let (names,currencyRates) = unzip $ [ (name,currencyRate) | Currency name currencyRate <- fromList_Currency listCurrency ] newBaseRate = float_val $ index "changeBaseCurrency" currencyRates newBase currencyRates' = map (\fl -> Float_ $ float_val fl / newBaseRate) currencyRates listCurrencies' = toList_Currency [ Currency name currency | (name,currency) <- zip names currencyRates' ] in if newBaseRate == 0 then clip else toClip $ Form name faculty expenses newBase listCurrencies' clip -> clip where float_val (Float_ f) = f float_val _ = 0 setCurrencyIx :: Path -> Int -> UpdateDoc Document ClipDoc setCurrencyIx path newCurrencyIx= \(DocumentLevel doc focus clip) -> let doc' = case selectD path doc of Clip_Expense (Expense desc amount _) -> pasteD path (Clip_Expense (Expense desc amount newCurrencyIx)) doc _ -> doc in DocumentLevel doc' focus clip -- Presentation utils leftTopMargins left top pres = row [ hSpace left, col [ vSpace top, pres] `withHStretch` True] `withStretch` True textField w pres = boxed $ row [hSpace 2, pres, empty `withHStretch` True] `withbgColor` white `withWidth` w -- setting width for entire pres including box is buggy in Xprez -- Utils showCurrency :: Float -> String showCurrency f = let s = formatRealFloat FFFixed (Just 2) f s' = reverse s -- s -- dropWhile (== '0') (reverse s) s'' = if head s' == '.' then '0':s' else s' in reverse s'' } -- TODO: why does withStretch not override col and row stretch settings? -- Stretch does not seem to work for text fields anymore -- empty has no background SEM Description [ | | strVal : String ] | Description loc.pres = parsingWithParserLexer pDescription (Lexer Lex.descr NonStyled) @self $ text @str lhs.strVal = @str | HoleDescription lhs.strVal = "{Description}" | ParseErrDescription lhs.strVal = "{parse error}" -- TODO: move this one to library SEM Float_ [ | | floatVal : Float ] | Float_ loc.pres = parsingWithParserLexer pFloat_ (Lexer Lex.float NonStyled) @self $ text (show @value) lhs.floatVal = @value | HoleFloat_ lhs.floatVal = 0 | ParseErrFloat_ lhs.floatVal = 0 SEM List_Thing | List_Thing loc.pres = structural $ col @elts.press `withbgColor` yellow SEM Thing | Thing loc.pres = structural $ row [text "x", text (show @size)] {- `withSize` ((@size+1) * 10,(@size+1) * 10) `withbgColor` blue -} `withMouseDown` (updateAt @lhs.path $ \clip -> case clip of (Clip_Thing (Thing nr)) -> Clip_Thing $ Thing (nr + 1) clip -> clip ) SEM Tasks | Tasks {- loc.pres = structural $ --row [ text "r" , col [ text "c", row [ text "r" , @things.pres --]]] -} loc.pres = structural $ (leftTopMargins 5 5 $ col [ hAlignCenter $ text "Task-list editor" , vSpace 20 -- @things1.pres -- , vSpace 20 -- , @things2.pres , text "Tasks:" `addPopupItems` ([ ("Insert task", docUpd $ insertElementAtEnd (toClip newTask) (@lhs.path++[2])) ] ++ showHideCompletedItem @lhs.path @self) , @tasks.pres `withFontSize` 12 ]`withStretch` True) `withStretch` True SEM List_Task | List_Task loc.pres = structural $ dropTarget Vertical $ -- row [ text "subtasks:" col $ map dragSource @elts.press -- loc.pres = structural $ draggableCol @elts.press SEM Task | BasicTask loc.pres = structural $ showHideCompleted @lhs.showCompleted @completed $ row [ hSpace $ 9 + 5 , presentCompleted @completed (not @completed) `withMouseDown` flipCompleted @lhs.path @self , hSpace 5, vRefHalf $ @description.pres `withColor` if @completed then green else blue] `addPopupItems` ([ ("Delete task", docUpd $ fixTask @lhs.path . deleteAt @lhs.path) , ("Insert subtask", docUpd $ changeToComposite @lhs.path) ] ++ mkMoveItems @lhs.path) | CompositeTask loc.pres = structural $ showHideCompleted @lhs.showCompleted @subtasks.completed $ col $ row [ (if @expanded then minusImg else plusImg) `withRef` (0,4) `withMouseDown` flipExpanded @lhs.path @self , hSpace 5 , presentCompleted @subtasks.completed @subtasks.notStarted `withMouseDown` setCompletedRec (not @subtasks.completed) @lhs.path @self , hSpace 5 , vRefHalf $ @description.pres `withColor` if @subtasks.completed then green else blue ] `addPopupItems` ([ ("Delete task", docUpd $ deleteAt @lhs.path) , ("Insert subtask", docUpd $ insertElementAtEnd (toClip newTask) (@lhs.path++[2])) ] ++ mkMoveItems @lhs.path) : if @expanded then [row [hSpace $ 9 + 5, @subtasks.pres]] else [] -- copy showCompleted field down to tasks ATTR List_Task ConsList_Task Task [ showCompleted : Bool | | ] SEM Tasks | Tasks tasks.showCompleted = @showCompleted ATTR List_Task ConsList_Task Task [ | | completed USE {&&} {True} : {Bool} ] ATTR List_Task ConsList_Task Task [ | | notStarted USE {&&} {True} : {Bool} ] SEM Task | BasicTask loc.completed = @completed loc.notStarted = not @completed { showHideCompleted showCompleted completed pres = if showCompleted || not completed then pres else empty showHideCompletedItem path (Tasks _ showCompleted _) = [ ((if showCompleted then "Hide " else "Show ") ++ " completed tasks" , docUpd $ updateAt path $ \clip -> case clip of Clip_Tasks (Tasks things _ tasks) -> toClip $ Tasks things (not showCompleted) tasks clip -> clip ) ] showHideCompletedItem _ _ = [] -- todo toClip in pasteAt flipCompleted path (BasicTask descr completed) = pasteAt path $ toClip $ BasicTask descr $ not completed flipExpanded path (CompositeTask expanded descr subtasks) = pasteAt path $ toClip $ CompositeTask (not expanded) descr subtasks setCompletedRec completed path task = pasteAt path $ toClip $ setCompletedRec' task where setCompletedRec' (BasicTask descr _) = BasicTask descr completed setCompletedRec' (CompositeTask exp descr subtasks) = CompositeTask exp descr $ toList_Task $ map setCompletedRec' (fromList_Task subtasks) presentCompleted completed notStarted = vRefHalf $ img (if completed then "img/completed.bmp" else if notStarted then "img/notStarted.bmp" else "img/partiallyCompleted.bmp") `withSize` (9,9) `withRef` (4,4) -- change parent composite to basic if it has no subtasks fixTask [] = id fixTask [_] = id fixTask path = let parentPath = (init (init path)) in updateAt parentPath $ \clip -> case clip of Clip_Task (CompositeTask _ descr (List_Task Nil_Task)) -> toClip $ BasicTask descr False clip -> clip changeToComposite path = updateAt path $ \clip -> case clip of (Clip_Task (BasicTask descr _)) -> Clip_Task $ CompositeTask True descr $ toList_Task [newTask] clip -> clip -- TODO: we either need the entire document here, or an isLast attribute to hide move down -- in case of the last task. mkMoveItems [] = [] mkMoveItems path = -- if last path > 0 -- then [ ("Move task up", docUpd $ moveElementUp path), ("Move task down", docUpd $ moveElementDown path) ] newTask = BasicTask (Description "") False } SEM Sudoku | Sudoku loc.pres = structural $ leftTopMargins 15 5 $ col [ hAlignCenter $ text "Sudoku solver" `withFontSize` 20 , vSpace 15 , hLine `withColor` darkGrey , @r0.pres, @r1.pres, @r2.pres , hLine `withColor` darkGrey , @r3.pres, @r4.pres, @r5.pres , hLine `withColor` darkGrey , @r6.pres, @r7.pres, @r8.pres , hLine `withColor` darkGrey , vSpace 30 , hAlignCenter $ mkButton 140 (text "Clear") $ docUpd $ updateAt @lhs.path $ const emptySudoku ] SEM Row | Row loc.pres = structural $ row [ vLine `withColor` darkGrey , @f0.pres, @f1.pres, @f2.pres , vLine `withColor` darkGrey , @f3.pres, @f4.pres, @f5.pres , vLine `withColor` darkGrey , @f6.pres, @f7.pres, @f8.pres , vLine `withColor` darkGrey ] SEM Field | Field loc.pres = structural $ boxed (col [ empty `withVStretch` True , row [ empty `withHStretch` True , bold $ @val.pres `withColor` black , empty `withHStretch` True ] , empty `withVStretch` True ] `withSize` (35,35)) `withColor` darkGrey `withbgColor` (if isValidField @val.value @lhs.rowNrs @lhs.colNrs @lhs.blockNrs then white else red) `addPopupItems` fieldPopupItems @lhs.path @lhs.rowNrs @lhs.colNrs @lhs.blockNrs @lhs.inhBoardStr @lhs.rowNr @lhs.colNr SEM Field [ | | val : Int ] | Field lhs.val = @val.value | HoleField lhs.val = -1 | ParseErrField lhs.val = -1 SEM Row [ | | rowNrs : {[Int]} ] | Row loc.rowNrs = [@f0.val,@f1.val,@f2.val,@f3.val,@f4.val,@f5.val,@f6.val,@f7.val,@f8.val] | HoleRow loc.rowNrs = [] | ParseErrRow loc.rowNrs = [] ATTR Field [ rowNrs : {[Int]} | | ] ATTR Row [ colsNrs : {([Int],[Int],[Int],[Int],[Int],[Int],[Int],[Int],[Int])} | | ] ATTR Field [ colNrs : {[Int]} | | ] SEM Sudoku | Sudoku loc.colsNrs = debug Prs (show @blockss)$ listTo9Tuple $ transpose [ @r0.rowNrs, @r1.rowNrs, @r2.rowNrs , @r3.rowNrs, @r4.rowNrs, @r5.rowNrs , @r6.rowNrs, @r7.rowNrs, @r8.rowNrs ] SEM Row | Row (f0.colNrs,f1.colNrs,f2.colNrs,f3.colNrs,f4.colNrs,f5.colNrs,f6.colNrs,f7.colNrs,f8.colNrs) = @lhs.colsNrs SEM Row [ | | rowGroups : {[[Int]]} ] | Row lhs.rowGroups = [ [@f0.val, @f1.val, @f2.val] , [@f3.val, @f4.val, @f5.val] , [@f6.val, @f7.val, @f8.val] ] | HoleRow lhs.rowGroups = [] | ParseErrRow lhs.rowGroups = [] ATTR Row [ blocks : {([Int],[Int],[Int])} | | ] SEM Sudoku | Sudoku loc.rowsGroups = [ [@r0.rowGroups, @r1.rowGroups, @r2.rowGroups ] , [@r3.rowGroups, @r4.rowGroups, @r5.rowGroups ] , [@r6.rowGroups, @r7.rowGroups, @r8.rowGroups ] ] loc.blockss = let [[nw,n,ne],[w,c,e],[sw,s,se]] = map (map concat . transpose) @rowsGroups in ((nw,n,ne),(w,c,e),(sw,s,se)) r0.blocks = fst3 @blockss r1.blocks = fst3 @blockss r2.blocks = fst3 @blockss r3.blocks = snd3 @blockss r4.blocks = snd3 @blockss r5.blocks = snd3 @blockss r6.blocks = thd3 @blockss r7.blocks = thd3 @blockss r8.blocks = thd3 @blockss ATTR Field [ blockNrs : {[Int]} | | ] SEM Row | Row f0.blockNrs = fst3 @lhs.blocks f1.blockNrs = fst3 @lhs.blocks f2.blockNrs = fst3 @lhs.blocks f3.blockNrs = snd3 @lhs.blocks f4.blockNrs = snd3 @lhs.blocks f5.blockNrs = snd3 @lhs.blocks f6.blockNrs = thd3 @lhs.blocks f7.blockNrs = thd3 @lhs.blocks f8.blockNrs = thd3 @lhs.blocks -- todo remame -- not quite an unboxed int, due to empty presentation for 0 SEM Int_ [ | | value : Int ] | Int_ loc.pres = parsingWithParserLexer pField (Lexer (Lex.int) NonStyled) @self $ text $ if @value == 0 then "" else show @value lhs.value = @value | HoleInt_ lhs.value = 0 | ParseErrInt_ lhs.value = 0 -- get a string representing the board in every field ATTR Sudoku Row Field [ | | synBoardStr USE {++} {[]} : String ] SEM Field | Field lhs.synBoardStr = if @val.value == 0 then " " else show @val.value ATTR Sudoku Row Field [ inhBoardStr : String | | ] SEM ChoiceDoc | SudokuDoc sudoku.inhBoardStr = @sudoku.synBoardStr -- row/column coordinates -- todo: nr is confusing here ATTR Row Field [ rowNr : Int | | ] SEM Sudoku | Sudoku (r0.rowNr,r1.rowNr,r2.rowNr,r3.rowNr,r4.rowNr,r5.rowNr,r6.rowNr,r7.rowNr,r8.rowNr) = (0,1,2,3,4,5,6,7,8) ATTR Field [ colNr : Int | | ] SEM Row | Row (f0.colNr,f1.colNr,f2.colNr,f3.colNr,f4.colNr,f5.colNr,f6.colNr,f7.colNr,f8.colNr) = (0,1,2,3,4,5,6,7,8) { emptySudoku :: ClipDoc emptySudoku = toClip $ Sudoku (Row (Field $ toInt_ 0) (Field $ toInt_ 0) (Field $ toInt_ 0) (Field $ toInt_ 0) (Field $ toInt_ 0) (Field $ toInt_ 0) (Field $ toInt_ 0) (Field $ toInt_ 0) (Field $ toInt_ 0)) (Row (Field $ toInt_ 0) (Field $ toInt_ 0) (Field $ toInt_ 0) (Field $ toInt_ 0) (Field $ toInt_ 0) (Field $ toInt_ 0) (Field $ toInt_ 0) (Field $ toInt_ 0) (Field $ toInt_ 0)) (Row (Field $ toInt_ 0) (Field $ toInt_ 0) (Field $ toInt_ 0) (Field $ toInt_ 0) (Field $ toInt_ 0) (Field $ toInt_ 0) (Field $ toInt_ 0) (Field $ toInt_ 0) (Field $ toInt_ 0)) (Row (Field $ toInt_ 0) (Field $ toInt_ 0) (Field $ toInt_ 0) (Field $ toInt_ 0) (Field $ toInt_ 0) (Field $ toInt_ 0) (Field $ toInt_ 0) (Field $ toInt_ 0) (Field $ toInt_ 0)) (Row (Field $ toInt_ 0) (Field $ toInt_ 0) (Field $ toInt_ 0) (Field $ toInt_ 0) (Field $ toInt_ 0) (Field $ toInt_ 0) (Field $ toInt_ 0) (Field $ toInt_ 0) (Field $ toInt_ 0)) (Row (Field $ toInt_ 0) (Field $ toInt_ 0) (Field $ toInt_ 0) (Field $ toInt_ 0) (Field $ toInt_ 0) (Field $ toInt_ 0) (Field $ toInt_ 0) (Field $ toInt_ 0) (Field $ toInt_ 0)) (Row (Field $ toInt_ 0) (Field $ toInt_ 0) (Field $ toInt_ 0) (Field $ toInt_ 0) (Field $ toInt_ 0) (Field $ toInt_ 0) (Field $ toInt_ 0) (Field $ toInt_ 0) (Field $ toInt_ 0)) (Row (Field $ toInt_ 0) (Field $ toInt_ 0) (Field $ toInt_ 0) (Field $ toInt_ 0) (Field $ toInt_ 0) (Field $ toInt_ 0) (Field $ toInt_ 0) (Field $ toInt_ 0) (Field $ toInt_ 0)) (Row (Field $ toInt_ 0) (Field $ toInt_ 0) (Field $ toInt_ 0) (Field $ toInt_ 0) (Field $ toInt_ 0) (Field $ toInt_ 0) (Field $ toInt_ 0) (Field $ toInt_ 0) (Field $ toInt_ 0)) isValidField nr rowNrs colNrs blockNrs = nr == 0 || length (filter (==nr) rowNrs) <= 1 && length (filter (==nr) colNrs) <= 1 && length (filter (==nr) blockNrs) <= 1 listTo9Tuple [x0,x1,x2,x3,x4,x5,x6,x7,x8] = (x0,x1,x2,x3,x4,x5,x6,x7,x8) fieldPopupItems :: Path -> [Int] -> [Int] -> [Int] -> String -> Int -> Int -> [ PopupMenuItem Document EnrichedDoc Node ClipDoc UserToken ] fieldPopupItems path rowNrs colNrs blockNrs boardStr row col = let validNrs = (([1..9] \\ rowNrs) \\ colNrs) \\ blockNrs in [ (if i == 0 then show "" else show i, docUpd $ setFieldValue path i) | i <- 0:validNrs ] ++ case sudokuHint boardStr row col of Just nr -> [ ( "Give hint" , docUpd $ pasteAt path $ toClip $ Field $ toInt_ nr) ] Nothing -> [ ("No hints, solution is incorrect", docUpd $ id) ] setFieldValue path n = pasteAt path $ toClip $ Field $ Int_ n -- http://www.sudokutoday.com/difficult-sudoku-puzzle-i1-answers.html } { -- TODO: move these to library -- called deleteAtPath in dazzleEditor deleteAt :: Path -> UpdateDoc Document ClipDoc deleteAt path = \(DocumentLevel d _ cl) -> editCutD (DocumentLevel d (PathD path) cl) pasteAt :: Path -> ClipDoc -> UpdateDoc Document ClipDoc pasteAt path clip = \(DocumentLevel d pathD cl) -> let (DocumentLevel d' _ _) = editPasteD (DocumentLevel d (PathD path) clip) in (DocumentLevel d' pathD cl) updateAt :: Path -> (ClipDoc -> ClipDoc) -> UpdateDoc Document ClipDoc updateAt path f = \(DocumentLevel d pathD cl) -> let clip = f (selectD path d) (DocumentLevel d' _ _) = editPasteD (DocumentLevel d (PathD path) clip) in (DocumentLevel d' pathD cl) -- PRECONDITION: path points to a list element of the same type as clip addElementAfter :: ClipDoc -> Path -> UpdateDoc Document ClipDoc addElementAfter clip path = \(DocumentLevel d pathD cl) -> (DocumentLevel (insertListD (init path) (last path+1) clip d) pathD cl) -- PRECONDITION: path points to a list of elements of the same type as clip -- NB path points to the list, not to an element. insertElementAtHead :: ClipDoc -> Path -> UpdateDoc Document ClipDoc insertElementAtHead clip listPath = \(DocumentLevel d pathD cl) -> (DocumentLevel (insertListD listPath 0 clip d) pathD cl) -- PRECONDITION: path points to a list of elements of the same type as clip -- NB path points to the list, not to an element. insertElementAtEnd :: ClipDoc -> Path -> UpdateDoc Document ClipDoc insertElementAtEnd clip listPath = \(DocumentLevel d pathD cl) -> let list = selectD listPath d in (DocumentLevel (insertListD listPath (arityClip list) clip d) pathD cl) -- up/down? maybe choose better name -- PRECONDITION: path points to an element in a list moveElementUp [] = id moveElementUp path = let parentListPath = init path indexInList = last path in \(DocumentLevel d f cl) -> if indexInList > 0 then let elt = selectD path d (d', f') = deleteD path d d'' = insertListD parentListPath (indexInList - 1) elt d' in DocumentLevel d'' f cl else DocumentLevel d f cl -- PRECONDITION: path points to an element in a list moveElementDown [] = id moveElementDown path = let parentListPath = init path indexInList = last path in \(DocumentLevel d f cl) -> if indexInList < arityClip (selectD parentListPath d) - 1 then let elt = selectD path d (d', f') = deleteD path d d'' = insertListD parentListPath (indexInList + 1) elt d' in DocumentLevel d'' f cl else DocumentLevel d f cl } SEM Test | Test loc.pres = structural $ leftTopMargins 30 40 $ col [ hAlignCenter $ text "Text with style" `withFontSize` 20 , vSpace 15 , row [ vLine , col [ hLine , vSpace 2 , row [ hSpace 2, mkButtonRow ] , vSpace 2 , hLine , @styledText.pres , hLine , @styledText.underwater `withFont'` ("Courier", 8) `withbgColor` lightGrey , hLine ] , vLine ] ] styledText.styles = [] { mkButtonRow = row [ mkButton 15 (bold $ text "B") $ WrappedLayEdit $ EditStyleLay SetBold , hSpace 3 , mkButton 15 (bold $ text "B" `withColor` lightGray) $ WrappedLayEdit $ EditStyleLay ClearBold , hSpace 3 , mkButton 15 (italic $ text "I") $ (WrappedLayEdit $ EditStyleLay SetItalic) , hSpace 3 , mkButton 15 (italic $ text "I"`withColor` lightGray) $ (WrappedLayEdit $ EditStyleLay ClearItalic) , hSpace 3 , mkButton 15 (text "-") $ (WrappedLayEdit $ EditStyleLay DecreaseFontSize) , hSpace 3 , mkButton 15 (text "+") $ (WrappedLayEdit $ EditStyleLay IncreaseFontSize) , hSpace 3 , mkButton 15 (text " ") (WrappedLayEdit $ EditStyleLay $ SetColor (0,0,0)) `withbgColor` (0,0,0) , hSpace 3 , mkButton 15 (text " ") (WrappedLayEdit $ EditStyleLay $ SetColor (255,0,0)) `withbgColor` (255,0,0) , hSpace 3 , mkButton 15 (text " ") (WrappedLayEdit $ EditStyleLay $ SetColor (0,255,0)) `withbgColor` (0,255,0) , hSpace 3 , mkButton 15 (text " ") (WrappedLayEdit $ EditStyleLay $ SetColor (0,0,255)) `withbgColor` (0,0,255) , empty `withHStretch` True , mkButton 40 (text "Parse") (WrappedLayEdit $ castLay ParseLay) ] `withFontSize` 8 } ATTR StyledText List_Word ConsList_Word Word List_WordPart ConsList_WordPart WordPart [ | styles : {[TextStyle]} | ] ATTR StyledText List_Word Word List_Word List_WordPart WordPart TextStyle [ | | underwater : Presentation_ ] SEM StyledText | StyledText loc.pres = parsingWithParserLexer pStyledText (Lexer (Lex.descr) Styled) @self $ @words.pres lhs.underwater = @words.underwater | HoleStyledText lhs.underwater = empty | ParseErrStyledText lhs.underwater = empty SEM List_Word | List_Word loc.pres = parsing $ formatter (if null @elts.press then [text ""] else @elts.styledPress) `withWidth` 800 lhs.underwater = formatter (if null @elts.underwaters then [text ""] else @elts.underwaters) -- for an empty paragraph, we add a dummy word "" so its presentation does not get height 0 | HoleList_Word lhs.underwater = empty | ParseErrList_Word lhs.underwater = empty -- need styledPress to apply correct styles to the spaces SEM ConsList_Word [ | | underwaters : {[Presentation_]} styledPress : {[Presentation_]} isLast : Bool ] | Cons_Word lhs.styledPress = @head.pres : (if not @tail.isLast then (applyStyles @head.styles (text " ") :) else id) @tail.styledPress lhs.underwaters = @head.underwater : (if not @tail.isLast then (applyStyles @head.styles (text " ") :) else id) @tail.underwaters lhs.isLast = False | Nil_Word lhs.underwaters = [] lhs.styledPress = [] lhs.isLast = True SEM Word | Word loc.pres = parsing $ @parts.pres lhs.underwater = @parts.underwater | HoleWord lhs.underwater = empty | ParseErrWord lhs.underwater = empty SEM List_WordPart | List_WordPart loc.pres = parsing $ row $ @elts.press lhs.underwater = row $ @elts.underwaters | HoleList_WordPart lhs.underwater = empty | ParseErrList_WordPart lhs.underwater = empty SEM ConsList_WordPart [ | | underwaters : {[Presentation_]} ] | Cons_WordPart lhs.underwaters = @head.underwater : @tail.underwaters | Nil_WordPart lhs.underwaters = [] SEM WordPart [ || ] | WordPart loc.pres = parsing $ applyStyles @lhs.styles $ row [ StringP @idp @word ] lhs.underwater = applyStyles @lhs.styles $ row [ text @word ] | OpenTag loc.pres = empty lhs.styles = @lhs.styles ++ [@style.self] lhs.underwater = bold $ row [text "<", @style.underwater, text ">"] | CloseTag loc.pres = empty lhs.styles = @lhs.styles \\ [@style.self] lhs.underwater = bold $ row [text ""] | HoleWordPart lhs.underwater = empty | ParseErrWordPart lhs.underwater = empty SEM TextStyle | TextBold loc.pres = structural $ empty lhs.underwater = text "b" | TextItalic loc.pres = structural $ empty lhs.underwater = text "i" | TextFontSize loc.pres = structural $ empty lhs.underwater = text $ "s("++show @s++")" | TextColor loc.pres = structural $ empty lhs.underwater = text $ "c("++show @r++","++show @g++","++show @b++")" | HoleTextStyle lhs.underwater = empty | ParseErrTextStyle lhs.underwater = empty { applyStyles [] pres = pres applyStyles (TextBold:styles) pres = applyStyles styles (bold pres) applyStyles (TextItalic:styles) pres = applyStyles styles (italic pres) applyStyles (TextFontSize s:styles) pres = applyStyles styles (pres `withFontSize` s) applyStyles (TextColor r g b:styles) pres = applyStyles styles (pres `withColor` (r,g,b)) }