MorphologicalAnalysis_Tool

globals
 [ mouseX mouseY
   max-categories ; maximum of categories allowed
   max-cells-in-column ; maximum of cells per column
   num_categories ; current number of categories
   column-offset ; from left, start of first category
   columns-width ; just that
   cells-height  ; Idem
   header-offset ; 
   headers-line  ; header's ycor
   cells-base-color primary-cell-color secondary-cell-color solution-space-color
   and-color xor-color-this xor-color-frozen;; for compare solution spaces' function
   initial-cell-defined ; first cell defined whed edit field
   initial-cell-column  ; column of initial cell
   toggle-links-flag
   frozen-primary-cells ; list of frozen cells [ [  catN nCell ] ... ]
   frozen-solution-cells
   
 ]
 

breed [cells cell]
cells-own [ catN nCell myLabel myDoc]

breed [categories category]
categories-own [ catN cellsHere myLabel ]

breed [banners banner]
banners-own [ catN ]  

undirected-link-breed [ rejected-links rejected-link ]
undirected-link-breed [ banner-links banner-link ]

to setup
  clear-all
  set-default-shape cells "rectangle"
  set-default-shape categories "category"
  ask patches [ set pcolor white]
  set max-categories 9
  set max-cells-in-column 12
  set num_categories 0
  set column-offset 5
  set header-offset 5
  set columns-width 9
  set cells-height 3
  set headers-line 39
  set cells-base-color 48  ; light yellow
  set primary-cell-color 19 ; light red
  set secondary-cell-color 26 ; orange + 1
  set solution-space-color 67 ; light green
  set and-color 64 ;; lime
  set xor-color-this 66 ;; lime + 3 (from last 'solve')
  set xor-color-frozen 68 ;; lime + 3 (from frozen)
  set initial-cell-defined false
  set toggle-links-flag true
  set frozen-primary-cells []
  set frozen-solution-cells []
  reset-ticks
end 

to go
   ifelse toggle-links-flag = true
     [ ask rejected-links [ hide-link ] set toggle-links-flag false ]
     [ ask rejected-links [ show-link ] set toggle-links-flag true ]
end 

to create-cell
    if mouse-down?
    [ 
      let xmouse mouse-xcor 
      if xmouse < column-offset + columns-width * num_categories
      [ let cat int(xmouse / columns-width )
        let cells-in-category [cellsHere] of one-of categories with [ catN = cat + 1]
        if cells-in-category >= max-cells-in-column 
           [ user-message "max cells in column were  reached" stop ]
        let cell-text user-input "description ?" if cell-text = "" or length cell-text > 20 [ stop ]
        addCell cat cell-text
        stop
      ]
    ]
end 

to addCell [ cat cell-text ]
        create-cells 1 [
          set catN cat + 1
          set myLabel cell-text
          ask categories with [ catN = cat + 1 ] [ set cellsHere cellsHere + 1 ]
          let myCellNumber [ cellsHere ] of one-of categories with [ catN = cat + 1 ] 
          set nCell myCellNumber
          setxy column-offset + cat * columns-width headers-line - myCellNumber * cells-height
          set size 9 set color cells-base-color
          attach-banner catN cell-text xcor ycor 
          ]
end 

to attach-banner [catNber cell-text x y]  ;; circle procedure
  hatch-banners 1 [
    set size 0 set xcor x + 2 set ycor y
    set label cell-text
    set catN catNber
    set label-color black
    create-banner-link-with myself [
      tie
      hide-link
    ]
  ]
end 

to create-category
    if num_categories = max-categories 
       [ user-message "max categories reached" stop ]
    let catName user-input "Category ?"
    if catName = "" [ stop ]
    addCategory num_categories catName
end 

to addCategory [ catNumber catName ]
    set num_categories num_categories + 1
    create-categories 1 [
      setxy column-offset + (num_categories - 1) * columns-width headers-line
      set catN catNumber + 1
      set cellsHere 0
      set myLabel catName
      let x xcor let y ycor
      set heading 0
      set size 9 set color black
      hatch-banners 1 [
        set size 0 set xcor x + 2 set ycor y
        set label catName
        set catN catNumber + 1
        set label-color black
        create-banner-link-with myself [
          tie
          hide-link
        ]
      ]
    ]
end 

to item-edit
  if mouse-down?
    [ 
      let thisItem min-one-of turtles [ distancexy mouse-xcor mouse-ycor ]
      if thisItem = nobody [ stop ]
      if is-cell? thisItem or is-category? thisItem
      [
      let chgMessage word "Please type new description to replace " [ myLabel ] of thisItem
      let newLabel user-input chgMessage
      let oldLabel "" let my_label_position 0
      ask thisItem 
       [ set oldLabel myLabel
         set myLabel newLabel 
         set my_label_position xcor + 2]
      ask banners with [ (label = oldLabel) and (xcor = my_label_position) ]
         [ set label newLabel ]
      stop
      ]
    ]
end 

to item-delete
  if mouse-down?
    [ let isCategory false
      let thisItem min-one-of turtles [ distancexy mouse-xcor mouse-ycor ] ; nearest turtle from click
      if thisItem = nobody [ stop ]                                        ; ... if any
      ifelse is-cell? thisItem [ let isCell true ] [let isCell false ]
      let catToDelete [ catN ] of thisItem
      if is-banner? thisItem [ stop ]
      let confirmMessage word "Please confirm you want to delete " [ myLabel ] of thisItem
      let deleted_cell_number 0
      if user-yes-or-no? confirmMessage
        [ if is-category? thisItem      ; if category, all cells in column should be deleted
          [ set isCategory true
            set num_categories num_categories - 1 
            ask cells with [ catN = catToDelete ]
               [ let my_label_position xcor + 2
                 ask banners with [ (label = [myLabel] of myself) and ( xcor = my_label_position) ] [ die ]
                 die 
               ]
          ]
          ask thisItem  ; and now the item itself can be deleted
            [ let my_label_position xcor + 2
              if not is-category? thisItem [ set deleted_cell_number nCell ] ; but when cell, reserve number to housekeeping
              ask banners with [ (label = [myLabel] of myself) and ( xcor = my_label_position) ] [ die ]
                                 die ]
        ifelse isCategory ; done, now reposition picture
          [ ask cells with [ catN > catToDelete ] ; on a category delete, all columns right should be shifted left
               [ set catN catN - 1
                 let my_label_position xcor + 2
                 set xcor xcor - columns-width
                 ask banners with [ (label = [myLabel] of myself) and ( xcor = my_label_position) ]
                      [ set xcor xcor - columns-width ]
               ]
            ask categories  with [ catN > catToDelete ]
               [ set catN catN - 1
                 let my_label_position xcor + 2
                 set xcor xcor - columns-width
                 ask banners with [ (label = [myLabel] of myself) and ( xcor = my_label_position) ]
                      [ set xcor xcor - columns-width ]
               ]
          ]
          [ ask cells with [ catN = catToDelete and nCell > deleted_cell_number ]
                [ let my_label_position xcor + 2
                  set ycor ycor + cells-height
                  set nCell nCell - 1
                ]
            ask categories with [ catN = catToDelete ] [ set cellsHere cellsHere - 1 ]
          ]
        stop
        ]  
     ]
end 

to save-model
  if file-exists? file-name
     [ ifelse user-yes-or-no? "File exists. Do you want to overwrite it?"
         [ file-delete file-name ]
         [ stop ] 
     ]     
  ifelse num_categories <= 1 
     [ user-message "Nothing to be saved !" ]
     [
       file-open file-name
       let thisCat 1 let catName "" let numCells 0
       let thisCell 0 let cellDescription ""
       while [ thisCat <= num_categories ]
          [
            set catName [ myLabel ] of one-of categories with [ catN = thisCat ]
            file-write catName
            set numCells [ cellsHere ] of one-of categories with [ catN = thisCat ]
            file-write numCells
            set thisCell 1
            while [ thisCell <= numCells ]
              [
                set cellDescription  [ myLabel ] of one-of cells with [ catN = thisCat and nCell = thisCell ]
                file-write cellDescription
                set thisCell thisCell + 1
              ]
              set thisCat thisCat + 1
          ]
          file-write "LINKS-LIST"
          ask rejected-links
             [ let cat1 [catN] of end1 let cellN1 [nCell] of end1
               let cat2 [catN] of end2 let cellN2 [nCell] of end2
               file-write cat1 file-write cellN1
               file-write cat2 file-write cellN2
             ] 
          file-close
          user-message "File has been saved"
     ]
end 

to load-model
  setup
  ifelse file-exists? file-name
    [  ; set loading-flag true
       file-open file-name
       let eof false
       let first-field ""
       let processing-links false
       let currentCatNumber 1
       let currentCatName "" let cellsNumber 0
       let newCell 0 let cellName ""
       while [ not file-at-end? ]
         [
           set currentCatName file-read
           if currentCatName = "LINKS-LIST" [ set processing-links true 
                                              ifelse file-at-end? [ set eof true] 
                                                  [set currentCatName file-read]]         
           if eof = false
           [
           ifelse processing-links = false
              [             ; Read model
                set cellsNumber file-read
                addCategory currentCatNumber - 1 currentCatName
                set newCell 1
                while [ newCell <= cellsNumber ]
                  [ set cellName file-read
                    addCell currentCatNumber - 1 cellName
                    set newCell newcell + 1
                  ]
                  set currentCatNumber currentCatNumber + 1 
              ]
              [             ; Links update
                set processing-links true
                let cat1 currentCatName let cell1 file-read
                let cat2 file-read let cell2 file-read
                ask cells with [ catN = cat1 and nCell = cell1]
                   [ create-rejected-links-with cells with [ catN = cat2 and nCell = Cell2 ] 
                   ]
              ]
           ]
         ]
                
       file-close ;set loading-flag false
    ]
    [ user-message "File does not exists !" ]
end 

to define-restrictions
  if mouse-down?
    [ 
      let thisItem min-one-of cells [ distancexy mouse-xcor mouse-ycor ]
      if is-cell? thisItem  and [catN] of thisItem != initial-cell-column
      [
         let thisItem-color [color] of thisItem
         ifelse initial-cell-defined = true
            [ ifelse thisItem-color = cells-base-color
                 [ ask thisItem [ set color secondary-cell-color ]
                 ]
                 [
                 if thisItem-color = secondary-cell-color
                    [ ask thisItem 
                      [ set color cells-base-color
                        ask my-rejected-links [ die ]
                      ]
                    ]
                 ]
            ]
            [ if thisItem-color = cells-base-color
                 [ ask thisItem [ set color primary-cell-color
                     set initial-cell-column catN
                     ask rejected-link-neighbors [ set color secondary-cell-color] ]
                   set initial-cell-defined true 
                 ]
            ]
      stop
      ]
    ]
end 

to invert
  ;; provided that only primary, secondary and base cells are on the world,
  ;;       turn secondaries on base and viceversa
  let noWay false
  ask cells
     [ if color != primary-cell-color and color != secondary-cell-color and color != cells-base-color
         [  set noWay true ] ]
  if noWay = true [ user-message "Only restrictions sets can be inverted" stop ]
  let catOfSelected [catN] of one-of cells with [ color = primary-cell-color ]
  let catNumber 1
  while [ catNumber <= num_categories ]
    [ if count cells with [ color = secondary-cell-color and catN = catNumber ] > 0
       [
       ask cells with [ catN != catOfSelected and catN = catNumber ]
        [ ifelse color = secondary-cell-color 
             [ set color cells-base-color ]
             [ if color = cells-base-color
                  [ set color secondary-cell-color ]
             ]
        ]
       ]
      set catNumber catNumber + 1
    ]
end 

to Apply-restrictions
  ask cells with [ color = primary-cell-color ] 
      [ create-rejected-links-with cells with [ color = secondary-cell-color ]]
  user-message "Selected restrictions has been applied"
  ask cells [ set color cells-base-color ]
  set initial-cell-defined false
  set initial-cell-column 0
end 

to show-restrictions
  if mouse-down?
    [ 
      let thisItem min-one-of cells [ distancexy mouse-xcor mouse-ycor ]
      if is-cell? thisItem
         [ ask thisItem 
           [ set color primary-cell-color
             ask rejected-link-neighbors [ set color secondary-cell-color ]
           ]
         ]
    stop
    ]      
end 

to clear-all-restrictions
     ask cells [ set color cells-base-color ]
     set initial-cell-defined false set initial-cell-column 0
end 

to define-scenario
  if mouse-down?
    [ 
      let thisItem min-one-of cells [ distancexy mouse-xcor mouse-ycor ]
      if is-cell? thisItem
            [ let thisItem-color [color] of thisItem
              ifelse thisItem-color = cells-base-color
                 [ ask thisItem [ set color primary-cell-color ]
                 ]
                 [ ask thisItem [ set color cells-base-color ]
                 ]
            ]
    stop
    ]
end 

to solve-scenario
  ;;;;            Only one selected cell by column is allowed
  let noChange true
  repeat num_categories - 1
  [
  ;; if any pair of selected cells is rejected => no solution 
   let noSolution false
   ask cells with [ color = primary-cell-color ] ;; ask all selected cells
       [ 
         if any? rejected-link-neighbors with [ color = primary-cell-color ] and noSolution = false ;; if they have some neighbor also selected 
         [ user-message "No solution for the selected cells" set noSolution true stop ] ;; in such a case, there's no solution.
       ]
   if noSolution = true [ stop ] ;; to continue has no sense
   ;; at first, reject all non-selected cells of a column with selected ones
   ask cells with [ color = primary-cell-color ]
       [ let thisCat catN
         ask cells with [ catN = thisCat and color != primary-cell-color ] [ set color secondary-cell-color ]
         ;; also reject cells linked by rejection-links
         ask rejected-link-neighbors [ set color secondary-cell-color ]
       ]
   ;; remaining cells are marked as candidates to solution
   ask cells with [color = cells-base-color] [ set color solution-space-color]
   ;; now, validate they are really solutions
   ask cells with [ color = solution-space-color ]
   [ let myCat catN
     let catNumber 1
     while [catNumber <= num_categories]
        [ let mark-out false
        if catNumber != myCat
        [
          let available-cells count cells with [ color = solution-space-color and [catN] of self = catNumber]
          let inhibited-cells count cells 
              with [ [catN] of self = catNumber and color = solution-space-color 
                     and ( rejected-link-neighbor? myself or any? rejected-link-neighbors with [ color = primary-cell-color])
                   ]
          if available-cells = inhibited-cells and available-cells != 0 [ set mark-out true ]
        ]
        if mark-out = true
           [ set color secondary-cell-color set noChange false]
        set catNumber catNumber + 1
        ]
   ]
   ;; Assure that at least one solution is available
   let catNumber 1
   while [catNumber <= num_categories] ;; It remains at least one solution-cell by column?
      [ 
        let solution-cells count cells with [ color = solution-space-color and catN = catNumber]
        let primary-cells count cells with [ color = primary-cell-color and catN = catNumber]
        if solution-cells + primary-cells = 0 [ user-message word "No solution because of " [ myLabel ] of one-of categories with [ catN = catNumber ]
                                                set noChange true
                                              ]
        set catNumber catNumber + 1
      ]
  if noChange = true [ stop ]
  ]
end 

to reset-all-links  ; delete all rejected-links
  if user-yes-or-no? "Please confirm deletion of all restrictions !"
     [ ask rejected-links [ die ]
       clear-all-restrictions
     ]
end 

to freeze
  ifelse any? cells with [ color = solution-space-color ]
  [
  set frozen-primary-cells [ ]
  ask cells with [ color = primary-cell-color ]
    [
    let thisCell [ ]
    set thisCell lput catN thisCell
    set thisCell lput nCell thisCell
    set frozen-primary-cells lput thisCell frozen-primary-cells
    ]
  set frozen-solution-cells [ ]
  ask cells with [ color = solution-space-color ]
    [
    let thisCell [ ]
    set thisCell lput catN thisCell
    set thisCell lput nCell thisCell
    set frozen-solution-cells lput thisCell frozen-solution-cells
    ]
    user-message "Solution space frozen."
  ]
  [ user-message "No solution space to freeze." ]
end 

to compare
  ifelse any? categories and any? cells and length frozen-primary-cells > 0
  [ foreach frozen-primary-cells ;; set primary cells from frozen
       [ let nCat item 0 ? let cellN item 1 ?
         ask one-of cells with [ catN = nCat and nCell = cellN ] [ set color primary-cell-color ] ]
    ask cells with [ color = primary-cell-color ] ;; mark as rejected cells not selected on columns with primaries
       [ let thisCat catN
         ; remaining cells on selected cells' columns are rejected
         ask cells with [ catN = thisCat and color != primary-cell-color ] [ set color secondary-cell-color ]
       ]
    ask cells with [ color = solution-space-color ]
       [ let listElement list catN nCell
         ifelse member? listElement frozen-solution-cells
            [ set color and-color ] [ set color xor-color-this ]
       ]
    ask cells with [ color = secondary-cell-color ]
       [ let listElement list catN nCell
         if member? listElement frozen-solution-cells
            [ set color xor-color-frozen ]
       ]
  ]
  [ user-message "Nothing to compare with." ]
end 

to recall
  ask cells [ set color secondary-cell-color ]
  foreach frozen-primary-cells
    [ ask cells with [ catN = item 0 ? and nCell = item 1 ? ] [ set color primary-cell-color] ]
  foreach frozen-solution-cells
    [ ask cells with [ catN = item 0 ? and nCell = item 1 ? ] [ set color solution-space-color] ]
end 

to stats
  ifelse any? categories and any? cells
  [ let totCells count cells
    let L1 (word "\nCategories : " num_categories "\nCells : " totCells)
    let totScen reduce * [cellsHere] of categories
    set L1 (word L1 "\nTotal configurations : " totScen) 
    let catList remove-duplicates [catN] of categories
    let cellList map [ count cells with [ catN = ? and ( color != secondary-cell-color) ] ] catList 
    let solSpaceSize reduce * cellList 
    let L2 word "\nSelected configurations : " solSpaceSize
    set L1 word L1 L2
    let redFactor precision ( 100 * ( totScen - solSpaceSize ) / totScen) 2
    set L1 ( word L1 "\nReduction factor : " redFactor " %.\n--------------------" )
    let colorCells count cells with [ color = primary-cell-color]
    if colorCells > 0 [ set L1 ( word L1 "\nSelected Cells : " colorCells) ]
    set colorCells count cells with [ color = secondary-cell-color]
    if colorCells > 0 [ set L1 ( word L1 "\nInhibited Cells : " colorCells) ]
    set colorCells count cells with [ color = solution-space-color]
    if colorCells > 0 [ set L1 ( word L1 "\nSolution Space Cells : " colorCells) ]
    set colorCells count cells with [ color = and-color]
    if colorCells > 0 [ set L1 ( word L1 "\nAND Cells : " colorCells) ]
    set colorCells count cells with [ color = xor-color-this]
    if colorCells > 0 [ set L1 ( word L1 "\nXOR Cells from last : " colorCells) ]
    set colorCells count cells with [ color = xor-color-frozen]
    if colorCells > 0 [ set L1 ( word L1 "\nXOR Cells from frozen : " colorCells) ]
    user-message L1
  ]
  [ user-message "No model has been defined."
  ]
end 

to show-density
  clear-all-restrictions
  ask cells [ let myLinksQty count rejected-link-neighbors
              set color scale-color red myLinksQty 30 0 ]
end